A simple haskell script to copy movie files from a directory to a storage area

videocopy.hs

#!/usr/bin/env runhaskell

import System.Directory
import Data.Char
import Data.Monoid
import Data.Maybe
import System.IO
import System (getArgs)
import Text.Printf

data VidFile = VidFile {
    showTitle :: String
    , year      :: Maybe Integer
    , season    :: Maybe Integer
    , episode   :: Maybe Integer
    , fileExt   :: String
    , file :: FilePath
}
    deriving (Show)

data ParseState = ParseState VidFile String
    deriving (Show)

emptyVidFile = VidFile {
    showTitle = ""
    , year = Nothing
    , season = Nothing
    , episode = Nothing
    , fileExt = ""
    , file = ""
}

concatMaybe (Just a) Nothing = Just a
concatMaybe _ Nothing = Nothing
concatMaybe _ (Just b) = Just b

combineVidFiles vf vf' = vf { showTitle = (showTitle vf) ++ (showTitle vf')
                              , year = concatMaybe (year vf) $ year vf'
                              , season = concatMaybe (season vf) $ season vf'
                              , episode = concatMaybe (episode vf) $ episode vf'
                              , fileExt = (fileExt vf) ++ (fileExt vf')
                              , file = (file vf) ++ (file vf')
}

instance Monoid VidFile where
    mempty = emptyVidFile
    mappend = combineVidFiles 

isIntString :: String -> Bool
isIntString s = isIntString' True s
    where isIntString' b "" = b
          isIntString' b (c : tl) =
            b && case c of
                    '1' -> isIntString' True tl
                    '2' -> isIntString' True tl
                    '3' -> isIntString' True tl
                    '4' -> isIntString' True tl
                    '5' -> isIntString' True tl
                    '6' -> isIntString' True tl
                    '7' -> isIntString' True tl
                    '8' -> isIntString' True tl
                    '9' -> isIntString' True tl
                    '0' -> isIntString' True tl
                    _   -> False

isSeasonString :: String -> Bool
isSeasonString ('S' : tl) = (length tl == 2) && (isIntString tl) 
isSeasonString ('s' : tl) = (length tl == 2) && (isIntString tl) 

parseTitle :: ParseState -> ParseState
parseTitle (ParseState vf "") = ParseState vf ""
parseTitle (ParseState vf rest) =
    let p   = take 4 rest
        suf = drop 4 rest
    in case p of
         ('S' : tl) -> handleSeasonCase ('S':tl)
         ('s' : tl) -> handleSeasonCase ('s':tl)
         _          -> if isIntString p -- probably a year
                       then ParseState (stripDot vf) rest -- terminataion state
                       else recurse rest -- tail recursion
     where recurse s = let hd = take 1 s
                           tl = tail s
                           vf' = mappend vf $ emptyVidFile {showTitle = hd}
                       in parseTitle $ ParseState vf' tl
           stripDot vf =
                let title = showTitle vf
                    len = (length title) - 1
                in if last (showTitle vf) == '.'
                   then vf {showTitle = take len title}
                   else vf
           handleSeasonCase p =
                if isSeasonString (take 3 p) -- season information
                then ParseState (stripDot vf) rest -- termination state
                else recurse rest -- tail recursion

parseSeason :: ParseState -> ParseState
parseSeason (ParseState vf (c:tl))
    | c == 'S' || c == 's' =
        let p = take 2 tl
            suf = drop 2 tl
            vf' = mappend vf $ emptyVidFile {season = Just (read p::Integer)}
        in if isIntString p
           then ParseState vf' suf 
           else ParseState vf (c:tl)
    | otherwise = ParseState vf (c:tl)

parseEpisode :: ParseState -> ParseState
parseEpisode (ParseState vf (c:tl))
    | c == 'E' || c == 'e' =
        let p = take 2 tl
            suf = drop 2 tl
            vf' = mappend vf $ emptyVidFile {episode = Just (read p::Integer)}
        in if isIntString p
           then ParseState vf' suf 
           else ParseState vf (c:tl)
    | otherwise = ParseState vf (c:tl)

parseSeasonAndEpisode = parseEpisode . parseSeason

parseYear :: ParseState -> ParseState
parseYear (ParseState vf rest) =
    let yr = take 4 rest
        suf = drop 4 rest
        vf' = mappend vf $ emptyVidFile {year = Just (read yr::Integer)}
    in if isIntString yr
       then ParseState vf' suf
       else ParseState vf rest

parseYearOrSeason (ParseState vf (c:tl))
    | c == 'S' || c == 's' = parseSeasonAndEpisode $ ParseState vf (c:tl)
    | otherwise = parseYear $ ParseState vf (c:tl)

parseExtension :: ParseState -> ParseState
parseExtension (ParseState vf rest) =
    let readExt acc (c:tl) =
            if c == '.'
            then acc
            else readExt (c:acc) tl
        ext = readExt "" $ reverse rest
        len = (length rest) - (length ext)
        vf' = mappend vf $ emptyVidFile {fileExt = ext}
    in ParseState vf' $ take len rest 

dropDot (ParseState vf ('.':tl)) = ParseState vf tl
dropDot p = p

parseAll s = 
    parseExtension $
    parseYearOrSeason $ dropDot $
    parseYearOrSeason $ dropDot $ 
    parseTitle (ParseState emptyVidFile s)

parse s = let ParseState vf _ = parseAll s
          in vf {file = s}

isFileType :: String -> String -> Bool
isFileType t fp = let t' = ('.' : t)
                      sz = ((length fp) - (length t'))
                      fpEnd = drop sz fp 
               in if fpEnd == t'
                  then True
                  else False

getFilesOfType d t = do
    fs <- getDirectoryContents d
    let fs' = filter (isFileType t) fs
    return fs'

myWords :: String -> [String]
myWords s = case dropWhile isDot s of
            "" -> []
            s' -> w : myWords s''
                  where (w, s'') =
                           break isDot s'
          where isDot = (\c -> c == '.')

dotize [] = ""
dotize [w] = w
dotize (w:ws) = w ++ '.' : dotize ws

capitalize = dotize . map capitalize' . myWords
    where capitalize' "" = ""
          capitalize' (c:tl) = toUpper c : map toLower tl

fileName vf = let title = capitalize (showTitle vf)
                  Just s = (season vf)
                  Just e = (episode vf)
                  ext = (fileExt vf)
              in title ++ ".S" ++ (printf "%02d" s)
                 ++ "E" ++ (printf "%02d" e)
                 ++ "." ++ ext

writeFileToDest :: FilePath -> VidFile -> IO ()
writeFileToDest path vf = do
    let title = capitalize (showTitle vf)
        f     = file vf
        dest  = path ++ "/" ++ title
        f'    = dest ++ "/" ++ (fileName vf)
    createDirectoryIfMissing True dest
    hPutStrLn stderr ("copying " ++ f ++ " to " ++ f')
    copyFile f f'

writeFilesToDest :: FilePath -> [VidFile] -> IO ()
writeFilesToDest path [] = do return ()
writeFilesToDest path (h:tl) = do
    writeFileToDest path h
    writeFilesToDest path tl

run :: FilePath -> IO ()
run path = do
    d <- getCurrentDirectory
    fs <- getFilesOfType d "avi"
    let vfs = map parse fs
    writeFilesToDest path vfs
    putStrLn $ show $ map file vfs

main :: IO ()
main = do
    args <- getArgs
    let dest = head args
    run dest