Monitor.hs

module Hoovie.Monitor (
        MonitorHandle,
        startMonitor,
        stopMonitor,
        getResources,
        getResourceById
    ) where

import Prelude hiding (catch)

import Control.Concurrent     (forkIO, ThreadId, killThread, threadDelay)
import System.Directory       (getDirectoryContents, doesDirectoryExist, doesFileExist, canonicalizePath, getModificationTime)
import System.FilePath        (joinPath, dropExtension, takeFileName)
import Control.Monad          (filterM, forever, forM_)
import Control.Exception      (bracket, finally, catch)
import Control.Exception.Base (SomeException)
import Data.List              (isSuffixOf)
import Data.Maybe             (mapMaybe)
import Data.Time              (UTCTime(..))
import Data.Time.Clock.POSIX  (posixSecondsToUTCTime)
import System.Time            (ClockTime(..))
import Text.Regex             (Regex, subRegex, mkRegex)

import Database.HDBC
import Database.HDBC.Sqlite3
import Debug.Trace

import Hoovie.Resource

supportedExtensions :: [String]
supportedExtensions = ["avi", "mp4"]

data MonitorHandle = MonitorHandle ThreadId

startMonitor :: [FilePath] -> FilePath -> IO MonitorHandle
startMonitor paths db = do
    pid <- forkIO $ monitor paths db
    return $ MonitorHandle pid

stopMonitor :: MonitorHandle -> IO ()
stopMonitor (MonitorHandle pid) = killThread pid

monitor :: [FilePath] -> FilePath -> IO ()
monitor paths db = forever $ (scan paths db `catch` logError) `finally` (threadDelay (5 * 1000000))

scan :: [FilePath] -> FilePath -> IO ()
scan paths db = listFiles paths supportedExtensions >>= syncDb db

logError :: SomeException -> IO ()
logError e = putStrLn $ show e

safely :: (Connection -> IO a) -> Connection -> IO a
safely f conn = handleSqlError $ f conn

withDb :: FilePath -> (Connection -> IO a) -> IO a
withDb db f = bracket (connectSqlite3 db)
                      (safely disconnect)
                      (safely f)

getResources :: FilePath -> IO [Resource]
getResources db = withDb db $ \conn -> do
    rows <- quickQuery' conn "SELECT id, filename, title, mod_date FROM files" []
    return $ mapMaybe toResource rows

getResourceById :: FilePath -> Maybe Int -> IO (Maybe Resource)
getResourceById _  Nothing    = return Nothing
getResourceById db (Just rid) = withDb db $ \conn -> do
    rows <- quickQuery' conn "SELECT id, filename, title, mod_date FROM files WHERE id=?" [toSql rid]
    return $ case rows of
                []    -> Nothing
                (a:_) -> toResource a

toResource :: [SqlValue] -> Maybe Resource
toResource row = 
    case row of
        [sqlId, sqlFilename, sqlTitle, sqlModDate] -> do
            rid      <- fromSql sqlId
            filename <- fromSql sqlFilename
            title    <- fromSql sqlTitle
            modDate  <- fromSql sqlModDate
            return $ Resource rid filename title modDate 4000 (688, 304) 102912 2 48000
        _ -> Nothing

fromResource :: Resource -> [SqlValue]
fromResource resource = 
    let conv f = toSql (f resource)
    in [ conv reFilename
       , conv reTitle
       , conv reDate
       -- , conv reDuration
       -- , conv reResolution
       -- , conv reBitrate
       -- , conv reAudioChannels
       -- , conv reSampleFreq
       ]

syncDb :: FilePath -> [(FilePath, UTCTime)] -> IO ()
syncDb db files = withDb db $ sync files

sync :: [(FilePath, UTCTime)] -> Connection -> IO ()
sync files conn = do
    _    <- run conn "CREATE TABLE IF NOT EXISTS files (id INTEGER PRIMARY KEY, filename TEXT NOT NULL, title TEXT NOT NULL, mod_date DATETIME)" []
    rows <- quickQuery' conn "SELECT id, filename, mod_date FROM files" []
    deleteDeletedFiles files rows conn
    insertNewFiles     files rows conn
    count <- quickQuery' conn "SELECT COUNT(*) FROM files" []
    putStrLn $ "Updated database: #files = " ++ show count
    commit conn

deleteDeletedFiles :: [(FilePath, UTCTime)] -> [[SqlValue]] -> Connection -> IO ()
deleteDeletedFiles files rows conn = do
    let toKeep   = [ (Just f, Just d) | (f, d) <- files ]
    let toDelete = [ [sqlId] | [sqlId, sqlFile, sqlModDate] <- rows, not $ (fromSql sqlFile, fromSql sqlModDate) `elem` toKeep ]
    runAll conn "DELETE FROM files WHERE id=?" toDelete
    trace ("DELETED FILES: " ++ show toDelete) (return ())

insertNewFiles :: [(FilePath, UTCTime)] -> [[SqlValue]] -> Connection -> IO ()
insertNewFiles files rows conn = do
    let inDatabase = [ (fromSql sqlFile, fromSql sqlModDate) | [_, sqlFile, sqlModDate] <- rows ]
    let toInsert   = [ f | f <- files, not $ f `elem` inDatabase ]
    resources <- mapM fromFile toInsert
    runAll conn "INSERT INTO files (filename, title, mod_date) VALUES (?, ?, ?)" $ map fromResource resources
    trace ("INSERTED FILES: " ++ show resources) (return ())
    
runAll :: Connection -> String -> [[SqlValue]] -> IO ()
runAll conn sql paramList = forM_ paramList $ \params -> quickQuery' conn sql params

fromFile :: (FilePath, UTCTime) -> IO Resource
fromFile (filename, modDate) = return $ Resource (-1) filename (getTitle filename) modDate 4000 (688, 304) 102912 2 48000

-- this function is no longer needed if we can upgrade to directory-1.2
toUTC :: ClockTime -> UTCTime
toUTC (TOD p _) = posixSecondsToUTCTime (fromIntegral p)

getTitle :: FilePath -> String
getTitle = replaceAll replacements . dropExtension . takeFileName

replacements :: [(Regex, String)]
replacements = map (\(p, v) -> (mkRegex p, v)) [
        ("\\b[Ww][Ww][Ww]\\.[^.]+\\.[A-Za-z]{1,3}\\b", ""),
        ("\\b[Bb][Rr][Rr][Ii][Pp]\\b", ""),
        ("\\b[Dd][Vv][Dd][Rr][Ii][Pp]\\b", ""),
        ("\\b[Dd][Vv][Dd][Rr]\\b", ""),
        ("\\b[Hh][Dd][Tt][Vv]\\b", ""),
        ("\\b[Xx][Vv][Ii][Dd]\\b", ""),
        ("\\b[Xx]264\\b", ""),
        ("\\b[Aa][Cc]3-5.1\\b", ""),
        ("\\b[Aa][Cc]3\\b", ""),
        ("\\b480[Pp]\\b", " "),
        ("\\b720[Pp]\\b", " "),
        ("\\b1080[Pp]\\b", " "),
        ("[.,-]", " "),
        ("\\([ ]*\\)", ""),
        ("\\[[^]]*\\]", ""),
        ("\\{[^}]*\\}", ""),
        ("^[ ]+", ""),
        ("[ ]+$", ""),
        (" [ ]+", " ")
    ]

replaceAll :: [(Regex, String)] -> String -> String
replaceAll ((p, v):ps) s = replaceAll ps $ subRegex p s v
replaceAll []          s = s

listFiles :: [FilePath] -> [String] -> IO [(FilePath, UTCTime)]
listFiles paths extensions = trace ("Scanning: " ++ show paths) $ concatMapM list paths
    where
        list :: FilePath -> IO [(FilePath, UTCTime)]
        list path = do
            exists <- doesDirectoryExist path
            if not exists 
                then return []
                else do
                    contents <- getDirectoryContents path
                    full     <- mapM canonicalizePath [ joinPath [path, name] | name <- contents, name /= ".", name /= ".." ]
                    dirs     <- filterM doesDirectoryExist full
                    files    <- filterM doesFileExist $ filter (hasExtension extensions) full
                    result   <- mapM addModificationTime files
                    subdir   <- concatMapM list dirs
                    return $ result ++ subdir

addModificationTime :: FilePath -> IO (FilePath, UTCTime)
addModificationTime path = do
    dt <- getModificationTime path
    return (path, toUTC dt)

hasExtension :: [String] -> FilePath -> Bool
hasExtension (e:es) path = e `isSuffixOf` path || hasExtension es path
hasExtension _      _    = False

concatMapM :: Monad m => (a -> m [b]) -> [a] -> m [b]
concatMapM f xs = mapM f xs >>= return . concat