{-# LANGUAGE OverloadedStrings #-}
module Main where


import Database.MongoDB as DB
import Text.HTML.TagSoup

import System.Environment
import System.IO
import System.Process
import Text.Printf
import System.Exit
import Control.Monad.Trans
import Network.URI
import Data.List.Split
import Data.Maybe
import Data.List (isPrefixOf,nub)
import Data.Char
import qualified Data.ByteString as BS
import qualified Data.ByteString.Char8 as BC8
import qualified Data.Text as T
import qualified Data.Text.Encoding as T
import qualified Data.Map as Map
import Control.Monad
import Control.Exception (evaluate)
import Prelude

import Data.Classify.Television

import Epguides

main :: IO ()
main = do
  args <- getArgs
  let addr = "localhost"
  case args of
    [port, "magnet"]         -> withMeteor addr port run
    [port, "shows"]          -> withMeteor addr port (getTVShows >>= liftIO . mapM_ putStrLn)
    [port, "add", name]      -> withMeteor addr port (addTVShow name)
    [port, "remove", name]   -> withMeteor addr port (removeTVShow name)
    [port, "epguides", name] -> withMeteor addr port (mkEpguidesEntries name)
    [port, "epguides_all"]   -> withMeteor addr port (mkAllEpguidesEntries)
    [port, "set_epguides", name, url] ->
      withMeteor addr port (setEpguides name url)
    [port, "rebuild"]        -> withMeteor addr port rebuild
    _ -> printUsage

withMeteor addr port fn = do
  pipe <- runIOE $ connect (Host addr (PortNumber (fromIntegral (read port :: Integer))))
  access pipe slaveOk "meteor" fn
  close pipe


printUsage :: IO ()
printUsage = do
  prog <- getProgName
  hPutStrLn stderr $ printf "Usage: %s <mongo_port> <command>\n" prog
  hPutStrLn stderr $ printf "Commands:"
  hPutStrLn stderr $ printf "     magnet          Fetch magnet links from stdin and add to DB."
  hPutStrLn stderr $ printf "     shows           List the recognized TV shows."
  hPutStrLn stderr $ printf "     add <name>      Add a name to the list of known TV shows."
  hPutStrLn stderr $ printf "     remove <name>   Remove a name to the list of known TV shows."
  hPutStrLn stderr $ printf "     epguides <name> Fetch titles and air-times from epguides."
  hPutStrLn stderr $ printf "     epguides_all    Fetch titles and air-times from epguides."
  hPutStrLn stderr $ printf "     set_epguides <name> <url> Associate <url> with <name>."
  hPutStrLn stderr $ printf "     rebuild         Recalculate computed properties in the DB."
  exitWith ExitSuccess


isMagnetLink :: URI -> Bool
isMagnetLink uri = uriScheme uri == "magnet:"

getDownloadName :: URI -> String
getDownloadName uri = fromMaybe "" $ listToMaybe $
  [ dn | ["dn", dn] <- map (splitOn "=") $ splitOn "&" (dropWhile (== '?') $ uriQuery uri) ]

getHash :: URI -> String
getHash uri = fromMaybe "" $ listToMaybe $
  [ xt | ["xt", xt] <- map (splitOn "=") $ splitOn "&" (dropWhile (== '?') $ uriQuery uri) ]


getTVShows = do
  records <- rest =<< find (select [] "meta") {project = [ "name" =: (1::Integer) ]}
  return $ nub $ mapMaybe (DB.lookup "name") records

addTVShow name =
  insert "meta" ["name" =: name]

setEpguides name url = do
  shows <- getTVShows
  unless (name `elem` shows) $ error $ "Unknown TV series: " ++ name
  modify (select ["name" =: name] "meta") ["$set" =: ["epguides" =: url]]

getEpguidesURL name = do
  entry <- findOne (select ["name" =: name] "meta")
  case DB.lookup "epguides" =<< entry of
    Nothing  -> error $ "No epguides URL associated with " ++ show name
    Just url -> return url

removeTVShow name =
  delete  (select ["name" =: name] "meta")

getTags :: String -> [String]
getTags = words . lower
  where
    lower str = [ if isAlphaNum c then c else ' ' | c <- str ]

run = do
  inp <- liftIO $ getContents
  let hrefs    = [ href | TagOpen "a" attrs <- parseTags inp, ("href", href) <- attrs ]
  shows <- getTVShows
  insertMagnetLinks shows hrefs

insertMagnetLinks shows uris = do
  let magnets  = [ uri | Just uri <- map parseURI uris, isMagnetLink uri ]
      elts = [ (uri, elt)
             | uri <- magnets
             , let dn = getDownloadName uri
             , Just elt <- [tryClassify shows dn]
             ]
  forM_ elts $ \(uri, (name, version, title)) -> do
    liftIO $ putStrLn $ "Adding element: " ++ show (name, version, title)
    let query = [ "name" =: name
                , case version  of
                    Version season episode     -> "episode" =: [ "season" =: season, "episode" =: episode ]
                    DateVersion year month day -> "airdate" =: [ "year" =: year, "month" =: month, "day" =: day ]
                ]
        inst = [ "link" =: show uri, "hash" =: getHash uri, "tags" =: getTags title ]
    modify (select query "episodes") ["$addToSet" =: ["instances" =: inst]]
  return ()


rebuild = do
  shows <- getTVShows
  records <- rest =<< find (select ["instances" =: ["$exists" =: True]] "episodes")
  forM_ records $ \record -> do
    let record_id = DB.lookup "_id" record :: Maybe ObjectId
    forM_ (fromMaybe [] (DB.lookup "instances" record)) $ \inst ->
      case DB.lookup "link" inst of
        Nothing  -> return ()
        Just uri -> do
          modify (select ["_id" =: record_id] "episodes") ["$pull" =: ["instances" =: inst]]
          insertMagnetLinks shows [uri]

mkAllEpguidesEntries = do
  shows <- getTVShows
  mapM_ mkEpguidesEntries shows

hGetContentsSafe :: Handle -> IO String
hGetContentsSafe handle = do
  inp <- BS.hGetContents handle
  case T.decodeUtf8' inp of
    Right txt -> return $ T.unpack txt
    Left err  -> do
      putStrLn $ "Failed to decode as UTF8: " ++ show err
      return $ BC8.unpack inp


{-
{name: TV show
,searchable: string
,airdate: {year: int, month: int, day: int}
,episode: {season: int, episode: int}
,title: string
,instances: [{link: magnet, hash: hash, tags: [string]}]
}
-}
mkEpguidesEntries name = do
  shows <- getTVShows
  unless (name `elem` shows) $ error $ "Unknown TV series: " ++ name
  liftIO $ putStrLn $ "Fetching meta information for show: " ++ name
  epguides_url <- getEpguidesURL name
  (inh, outh, errh, pid) <- liftIO $ runInteractiveProcess "wget" ["-q", "-O", "-", epguides_url] Nothing Nothing
  liftIO $ hClose inh >> hClose errh
  inp <- liftIO $ hGetContentsSafe outh
  liftIO $ evaluate (length inp)
  _ <- liftIO $ waitForProcess pid

  db <- rest =<< find (select ["name" =: name] "episodes") { project = ["episode" =: True, "title" =: True] }
  let dbAssoc =
        catMaybes
          [ do idx <- DB.lookup "episode" x
               title <- DB.lookup "title" x
               return (idx, title)
          | x <- db ]

  forM_ (parseEpguide inp) $ \(EpIdx season episode, (year, month, day), title) -> do
    let query = ["name" =: name, "episode" =: idx ]
        idx = ["season" =: season, "episode" =: episode ]
        airdate = ["year" =: year, "month" =: month, "day" =: day]
    case Prelude.lookup idx dbAssoc of
      Nothing -> do
        liftIO $ putStrLn $ "Inserting new: " ++ show (season, episode, year, month, day, title)
        insert_ "episodes"  [ "name"       =: name
                            , "episode"    =: ["season" =: season, "episode" =: episode]
                            , "airdate"    =: airdate
                            , "title"      =: title
                            ]
      Just oldTitle | oldTitle == title ->
        --liftIO $ putStrLn $ "Skipping: " ++ show (season, episode, year, month, day, title)
        return ()
      Just oldTitle -> do
        liftIO $ putStrLn $ "Updating: " ++ show (season, episode, year, month, day, oldTitle, title)
        modify (select query "episodes") ["$set" =: ["title" =: title, "airdate" =: airdate]]