-- ------------------------------------------------------------------------------------------- -- IB016 - spring 2018 - example solution of the third homework. -- Packages: filepath, directory (>= 1.3.0.0), regex-tdfa -- ------------------------------------------------------------------------------------------- module Main ( main ) where import System.Console.GetOpt( OptDescr( .. ), ArgOrder( .. ), ArgDescr( .. ), usageInfo, getOpt ) import System.Environment( getArgs ) import System.FilePath( (), (<.>), takeExtension, takeFileName, takeDirectory ) import System.Directory( listDirectory, copyFileWithMetadata, createDirectoryIfMissing, renameFile, removeFile, doesDirectoryExist, doesPathExist, pathIsSymbolicLink ) import System.IO( stderr, hPutStr ) import Control.Monad( when, unless ) import Control.Applicative( (<|>) ) import Control.Exception( IOException, catch, throw ) import GHC.IO.Exception( IOException( IOError ), IOErrorType( UnsupportedOperation ) ) import Data.Maybe( fromMaybe, fromJust, mapMaybe ) import Data.Monoid( Any( Any ), getAny, Last( Last ), getLast ) import Data.Char( isAlphaNum, toLower ) import Data.List( isInfixOf ) import Text.Printf( printf ) import Text.Regex.TDFA( (=~) ) fileSuffixes :: [ String ] fileSuffixes = ('.':) <$> [ "avi", "mkv", "mp4", "ts", "mpeg", "srt" ] data SEFormat = Ex | CapitalS | LowerS deriving ( Eq, Show ) data TidyConf = TidyConf { optEpList :: Last FilePath , optFormat :: Last SEFormat , optSanitize :: Last Bool , optHelp :: Any , optVerbose :: Any , optDry :: Any } deriving( Eq, Show ) instance Monoid TidyConf where mappend a b = TidyConf { optEpList = optEpList a `mappend` optEpList b , optFormat = optFormat a `mappend` optFormat b , optSanitize = optSanitize a `mappend` optSanitize b , optHelp = optHelp a `mappend` optHelp b , optVerbose = optVerbose a `mappend` optVerbose b , optDry = optDry a `mappend` optDry b } mempty = TidyConf { optEpList = Last Nothing , optFormat = Last Nothing , optSanitize = Last Nothing , optHelp = Any False , optVerbose = Any False , optDry = Any False } defaultConf :: TidyConf defaultConf = TidyConf { optEpList = Last Nothing , optFormat = Last (Just LowerS) , optSanitize = Last (Just True) , optHelp = Any False , optVerbose = Any False , optDry = Any False } usage :: String usage = usageInfo usageHeader options where usageHeader = "USAGE: ./tidyvids [OPTIONS] TITLE SOURCE_DIR VIDEO_COLLECTION_ROOT." ++ "\nTL;DR: ./tidyvids -l tog.list \"Throne of Games\" ~/Downloads ~/Videos" options :: [ OptDescr TidyConf ] options = [ Option "h?" ["help"] ( NoArg mempty { optHelp = Any True } ) "display this help and exit" , Option "v" ["verbose"] ( NoArg mempty { optVerbose = Any True } ) "report what is being done" , Option "n" ["dry", "dry-run"] ( NoArg mempty { optVerbose = Any True, optDry = Any True } ) "do not make any changes, only report what would be done; implies -v" , Option "" ["sanitize"] ( NoArg mempty { optSanitize = Last (Just True) } ) "sanitize filenames for use in FAT and NTFS (default behaviour)" , Option "" ["no-sanitize"] ( NoArg mempty { optSanitize = Last (Just False) } ) "do not sanitize filenames" , Option "l" ["list-file"] ( ReqArg ( \p -> mempty { optEpList = Last ( Just p ) } ) "FILE" ) ( "use FILE for assigning episode names. Each line in FILE should be in format\n" ++ "\"SSxEE Episode Title\" (excl. quotation marks, SS and EE are two-digit\n" ++ "zero-padded season and episode numbers and any spaces and tabs before the\n" ++ "episode title are ignored)." ) , Option "f" ["format"] ( ReqArg ( \f -> mempty { optFormat = Last ( readSEFormat f ) } ) "FORMAT" ) ( "use FORMAT for numbering episodes. Defaulting to 's', the recognized values are:" ++ "\nx -> 01x09\ns -> s01e09\nS -> S01E09" ) ] readSEFormat :: String -> Maybe SEFormat readSEFormat "x" = Just Ex readSEFormat "s" = Just LowerS readSEFormat "S" = Just CapitalS readSEFormat _ = Nothing putErr :: String -> IO () putErr = hPutStr stderr main :: IO () main = getOpt RequireOrder options <$> getArgs >>= buildConfigAndRun buildConfigAndRun :: ( [ TidyConf ], [ String ], [ String ] ) -> IO () buildConfigAndRun ( opts, paths, [] ) | getAny $ optHelp conf = putStr usage | length paths /= 3 = putErr $ "Error: a name and exactly two paths must be given\n" ++ usage | otherwise = checkConfigAndRun conf title srcDir dstDir where conf = mconcat ( defaultConf : opts ) [title, srcDir, dstDir] = paths buildConfigAndRun ( _, _, errors ) = putErr $ concat errors ++ usage checkConfigAndRun :: TidyConf -> String -> FilePath -> FilePath -> IO () checkConfigAndRun conf title srcDir dstDir = buildEpisodeDB ( getLast $ optEpList conf ) >>= return . map ( \(ep, name) -> (ep, sane name) ) >>= \epdb -> findSourceFiles ctitle srcDir >>= return . mapMaybe parseInfo >>= return . map ( generateMvPair saneDstDir saneTitle fmt . addEpisodeTitle epdb ) >>= mapM_ ( runMv verbose dryrun ) where saneTitle = sane title ctitle = canonicName saneTitle saneDstDir = dstDir saneTitle sane = sanitize ( fromJust . getLast . optSanitize $ conf ) fmt = ( fromJust . getLast . optFormat ) conf verbose = ( getAny . optVerbose ) conf dryrun = ( getAny . optDry ) conf canonicName :: String -> String canonicName = map toLower . filter isAlphaNum buildEpisodeDB :: Maybe FilePath -> IO [ ( ( Int, Int ), String ) ] buildEpisodeDB Nothing = return [] buildEpisodeDB ( Just file ) = ( mapMaybe parseEpisodeName . lines ) <$> readFile file where parseEpisodeName :: String -> Maybe ( ( Int, Int ), String ) parseEpisodeName l = case l =~ epdbRegex :: (String, String, String, [String]) of (_, [], _, _) -> Nothing (_, _, _, [season, episode, title]) -> Just ((read season, read episode), title) epdbRegex = "^([0-9]{2,2})x([0-9]{2,2})[ \t]+(.*)$" findSourceFiles :: String -> FilePath -> IO [ FilePath ] findSourceFiles ctitle path = catch ( findSourceFilesThrowing ctitle path ) ( \e -> putErr "Error: " >> print ( e :: IOException ) >> return [] ) findSourceFilesThrowing :: String -> FilePath -> IO [ FilePath ] findSourceFilesThrowing ctitle path = do isdir <- doesDirectoryExist path issymlink <- pathIsSymbolicLink path if isdir && not issymlink then map (path ) <$> listDirectory path >>= mapM (findSourceFiles ctitle) >>= return . concat else if takeExtension path `elem` fileSuffixes && ctitle `isInfixOf` ( canonicName . takeFileName ) path then return [ path ] else return [] -- Note: <|> is an operator of the Alternative class. For Maybe it is defined as such: -- Nothing <|> b = b -- just_a <|> _ = just_a parseInfo :: FilePath -> Maybe ( FilePath, Int, Int ) parseInfo path = parseInfoWith infoRegexSE <|> parseInfoWith infoRegexX where parseInfoWith :: String -> Maybe ( FilePath, Int, Int ) parseInfoWith regex = case path =~ regex :: (String, String, String, [String]) of (_, [], _, _) -> Nothing (_, _, _, [season, episode]) -> Just ( path, read season, read episode ) infoRegexSE = "[sS]([0-9]{1,2})[eE]([0-9]{1,2})" infoRegexX = "([0-9]{1,2})[xX]([0-9]{1,2})" loadEpisodeTitle :: [ ( ( Int, Int ), String ) ] -> ( Int, Int ) -> String loadEpisodeTitle db ep = fromMaybe "" ( lookup ep db ) addEpisodeTitle :: [ ( ( Int, Int ), String ) ] -> ( FilePath, Int, Int ) -> ( FilePath, Int, Int, String ) addEpisodeTitle db ( path, s, e ) = ( path, s, e, loadEpisodeTitle db ( s, e ) ) generateMvPair :: FilePath -> String -> SEFormat -> ( FilePath, Int, Int, String ) -> ( FilePath, FilePath ) generateMvPair dir title fmt ( src, s, e, etitle ) = let filename = title ++ " - " ++ generateEpisode fmt s e etitle seasondir = "Season " ++ zeropad2 s dst = dir seasondir filename <.> takeExtension src in ( src, dst ) generateEpisode :: SEFormat -> Int -> Int -> String -> String generateEpisode fmt s e title = before fmt ++ zeropad2 s ++ between fmt ++ zeropad2 e ++ if null title then "" else " - " ++ title where before Ex = "" before CapitalS = "S" before LowerS = "s" between Ex = "x" between CapitalS = "E" between LowerS = "e" zeropad2 :: Int -> String zeropad2 = printf "%02d" sanitize :: Bool -> String -> String sanitize b = filter (`notElem` forbidden) where forbidden = if b then winForbidden else unixForbidden unixForbidden = "\0/" winForbidden = '\x7f' : ['\x01'..'\x1f'] ++ "\\?|<>:*\"" ++ unixForbidden runMv :: Bool -> Bool -> ( FilePath, FilePath ) -> IO () runMv verbose dryrun ( src, dst ) = do when verbose ( putStrLn ( ( if dryrun then "Would move " else "Moving " ) ++ src ++ " -> " ++ dst ) ) unless dryrun ( catch ( runMvThrowing src dst ) ( \e -> putErr "Error: " >> print ( e :: IOException ) ) ) runMvThrowing :: FilePath -> FilePath -> IO() runMvThrowing src dst = do dstExists <- doesPathExist dst when dstExists ( -- Note: "fail" in the IO monad throws an IOException. Alternatively, we could just -- print the error message here and prevent the rest of the do-block from happening. fail $ '\"' : dst ++ "\" already exists." ) createDirectoryIfMissing True ( takeDirectory dst ) catch ( renameFile src dst ) ( \e -> case e of -- UnsupportedOperation = cannot rename across partitions, we need to copy ( IOError _ UnsupportedOperation _ _ _ _ ) -> copyFileWithMetadata src dst >> removeFile src -- Other exception: rethrow _ -> throw e )