<commit_before>
{-# LANGUAGE OverloadedStrings #-}

module Mdb.TvShow ( doMode ) where

import           Control.Monad.Catch         (MonadCatch, try)
import           Control.Monad.IO.Class      (MonadIO, liftIO)
import           Control.Monad.Reader.Class  (asks)
import           Control.Monad.Trans.Class   (lift)
import           Control.Monad.Trans.Either
import           Control.Monad.Trans.Reader  (ReaderT)
import qualified Data.ByteString.Lazy        as BSL
import           Data.Char ( toLower )
import           Data.Int                    (Int64)
import           Data.List                   (nub, sort)
import           Data.Maybe                  (mapMaybe)
import           Data.Monoid                 ((<>))
import qualified Data.Text                   as T
import           Data.Text.Encoding          (decodeUtf8)
import           Network.HTTP.Client.Conduit (Manager, Response, httpLbs,
                                              parseUrl, responseBody,
                                              withManager)
import           Network.HTTP.Conduit        (HttpException)
import           System.Directory            (createDirectoryIfMissing)
import           System.FilePath             (splitDirectories, takeDirectory,
                                              takeExtension)
import qualified Text.XML.Light              as XML

import           Mdb.CmdLine                 (OptTvShow (..))
import           Mdb.Database
import           Mdb.Database.File           (FileId)
import           Mdb.File                    (checkFile)
import           Mdb.Types

tvDbApiKey :: String
tvDbApiKey = "2FA137A801CEDA74"

tvDbBase :: String
tvDbBase = "http://thetvdb.com/"

tvDbApiBase :: String
tvDbApiBase = tvDbBase ++ "api/"

authBase :: String
authBase = tvDbApiBase  ++ tvDbApiKey ++ "/"

doMode :: OptTvShow -> MDB IO ()
doMode (AssignTvShow lang folders) = withManager $ mapM_ go folders where
    go folder = scanShow lang folder >>= \x -> case x of
        Left msg    -> liftIO $ putStrLn $ T.unpack $ "error: " <> msg
        Right ()    -> return ()

eName :: String -> XML.QName
eName n = XML.QName n Nothing Nothing

xmlBody :: Monad m => Response BSL.ByteString -> EitherT T.Text m XML.Element
xmlBody resp = case (XML.parseXMLDoc . decodeUtf8 . BSL.toStrict . responseBody) resp of
    Nothing     -> left "failed to parse response as XML"
    Just xml    -> right xml

scanShow :: String -> FilePath -> ReaderT Manager (MDB IO) (Either T.Text ())
scanShow lang showDir = runEitherT $ do
    let
        dirs = splitDirectories showDir
        dirName = last dirs

    esid <- lift . lift $ do
        rel <- relFile showDir
        dbQueryOne "SELECT series_id, series_name FROM series WHERE ? LIKE (series_root || '%')" (Only rel)

    case esid of
        Right (serId, name) -> liftIO $ putStrLn $ showDir ++ ": already assigned to \""
                                                ++ name ++ "\" (" ++ show (serId :: SerialId) ++ ")"

        Left _              -> do
            liftIO $ putStrLn $ "fetching info for \"" ++ last dirs ++ "\""

            xml <- parseUrl (tvDbApiBase ++ "GetSeries.php?seriesname=" ++ dirName ++ "&language=" ++ lang)
                >>= httpLbs >>= xmlBody

            case XML.findChildren (eName "Series") xml of
                []  -> left "no candidate found"
                [x] -> assign lang showDir x
                xs  -> pick xs dirName lang >>= assign lang showDir

pick :: [XML.Element] -> String -> String -> EitherT T.Text (ReaderT Manager (MDB IO)) XML.Element
pick els dirName lang = do
    let
        lCase           = map toLower
        field name xml  = XML.strContent <$> XML.findChild (eName name) xml
        wrap xml        =
            (,)
                <$> ((,,) <$> field "SeriesName" xml <*> field "FirstAired" xml <*> field "language" xml)
                <*> pure xml
        wrapped         = mapMaybe wrap els
        langMatch       = filter (\((_, _, l), _) -> lCase lang == lCase l) wrapped
        exactName       = filter (\((n, _, _), _) -> lCase dirName == lCase n) langMatch<commit_msg>mdb: Even better error messages<commit_after>
{-# LANGUAGE OverloadedStrings #-}

module Mdb.TvShow ( doMode ) where

import           Control.Monad.Catch         (MonadCatch, try)
import           Control.Monad.IO.Class      (MonadIO, liftIO)
import           Control.Monad.Reader.Class  (asks)
import           Control.Monad.Trans.Class   (lift)
import           Control.Monad.Trans.Either
import           Control.Monad.Trans.Reader  (ReaderT)
import qualified Data.ByteString.Lazy        as BSL
import           Data.Char ( toLower )
import           Data.Int                    (Int64)
import           Data.List                   (nub, sort)
import           Data.Maybe                  (mapMaybe)
import           Data.Monoid                 ((<>))
import qualified Data.Text                   as T
import           Data.Text.Encoding          (decodeUtf8)
import           Network.HTTP.Client.Conduit (Manager, Response, httpLbs,
                                              parseUrl, responseBody,
                                              withManager)
import           Network.HTTP.Conduit        (HttpException)
import           System.Directory            (createDirectoryIfMissing)
import           System.FilePath             (splitDirectories, takeDirectory,
                                              takeExtension)
import qualified Text.XML.Light              as XML

import           Mdb.CmdLine                 (OptTvShow (..))
import           Mdb.Database
import           Mdb.Database.File           (FileId)
import           Mdb.File                    (checkFile)
import           Mdb.Types

tvDbApiKey :: String
tvDbApiKey = "2FA137A801CEDA74"

tvDbBase :: String
tvDbBase = "http://thetvdb.com/"

tvDbApiBase :: String
tvDbApiBase = tvDbBase ++ "api/"

authBase :: String
authBase = tvDbApiBase  ++ tvDbApiKey ++ "/"

doMode :: OptTvShow -> MDB IO ()
doMode (AssignTvShow lang folders) = withManager $ mapM_ go folders where
    go folder = scanShow lang folder >>= \x -> case x of
        Left msg    -> liftIO $ putStrLn $ T.unpack $ "error: " <> msg
        Right ()    -> return ()

eName :: String -> XML.QName
eName n = XML.QName n Nothing Nothing

xmlBody :: Monad m => Response BSL.ByteString -> EitherT T.Text m XML.Element
xmlBody resp = case (XML.parseXMLDoc . decodeUtf8 . BSL.toStrict . responseBody) resp of
    Nothing     -> left "failed to parse response as XML"
    Just xml    -> right xml

scanShow :: String -> FilePath -> ReaderT Manager (MDB IO) (Either T.Text ())
scanShow lang showDir = runEitherT $ do
    let
        dirs = splitDirectories showDir
        dirName = last dirs

    esid <- lift . lift $ do
        rel <- relFile showDir
        dbQueryOne "SELECT series_id, series_name FROM series WHERE ? LIKE (series_root || '%')" (Only rel)

    case esid of
        Right (serId, name) -> liftIO $ putStrLn $ showDir ++ ": already assigned to \""
                                                ++ name ++ "\" (" ++ show (serId :: SerialId) ++ ")"

        Left _              -> do
            liftIO $ putStrLn $ "fetching info for \"" ++ last dirs ++ "\""

            xml <- parseUrl (tvDbApiBase ++ "GetSeries.php?seriesname=" ++ dirName ++ "&language=" ++ lang)
                >>= httpLbs >>= xmlBody

            case XML.findChildren (eName "Series") xml of
                []  -> left $ "no candidate found for \"" <> T.pack dirName <> "\""
                [x] -> assign lang showDir x
                xs  -> pick xs dirName lang >>= assign lang showDir

pick :: [XML.Element] -> String -> String -> EitherT T.Text (ReaderT Manager (MDB IO)) XML.Element
pick els dirName lang = do
    let
        lCase           = map toLower
        field name xml  = XML.strContent <$> XML.findChild (eName name) xml
        wrap xml        =
            (,)
                <$> ((,,) <$> field "SeriesName" xml <*> field "FirstAired" xml <*> field "language" xml)
                <*> pure xml
        wrapped         = mapMaybe wrap els
        langMatch       = filter (\((_, _, l), _) -> lCase lang == lCase l) wrapped
        exactName       = filter (\((n, _, _), _) -> lCase dirName == lCase n) langMatch
{'fraction_non_alphanumeric': 0.10454600265283974, 'fraction_numerical': 0.0031351742433377546, 'mean_word_length': 1.6824062095730918, 'pattern_counts': {'":': 2, '<': 27, '<?xml version=': 0, '>': 79, 'https://': 0, 'lorem ipsum': 0, 'www.': 0, 'xml': 28}, 'pii_count': 0, 'substrings_counts': 0, 'word_list_counts': {'cursed_substrings.json': 16, 'profanity_word_list.json': 0, 'sexual_word_list.json': 0, 'zh_pornsignals.json': 0}}
{'dir': 'git-commits-cleaned', 'id': '1308865', 'n_tokens_mistral': 2341, 'n_tokens_neox': 2268, 'n_words': 678}