{-| Module : RatingChgkInfo.NoApi Description : Функции для работы с CSV сайта рейтинга Copyright : (c) Mansur Ziiatdinov, 2018-2019 License : BSD-3 Maintainer : chgk@pm.me Stability : experimental Portability : POSIX Функции в этом модуле позволяют получить досутп к функциональности, которой нет в REST API сайта рейтинга, но которая реализуется через экспорт CSV-таблиц. На данный момент реализована только функция получения списка заявок турнира (вместе с введёнными командами). -} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE StrictData #-} module RatingChgkInfo.NoApi ( requests , synchTown , towns ) where import Prelude hiding (ByteString, get) import RatingChgkInfo.Types import RatingChgkInfo.Types.Unsafe (TournamentId (..), PlayerId (..)) import Codec.Text.IConv import Control.Lens import qualified Data.ByteString.Char8 as B import Data.ByteString.Lazy.Char8 (ByteString) import qualified Data.ByteString.Lazy.Char8 as BL import Data.Char import Data.Csv import Data.Fixed import Data.List import qualified Data.Map as M import qualified Data.Map.Merge.Lazy as M import Data.Text (Text) import qualified Data.Text as T import Data.Text.Read import Data.Time import Network.Wreq import Text.HTML.TagSoup -- Команда в CSV data CsvTeam = CsvTeam { ctTown :: Text , ctRepId :: Maybe Int , ctRepSurname :: Text , ctRepName :: Text , ctRepPatronym :: Text , ctTeamId :: Int , ctTeam :: Text , ctTeamTown :: Text , ctFlags :: Text , ctTeamBaseName :: Text , ctTeamBaseTown :: Text , ctBaseIsCurrent :: Int } deriving (Eq,Show,Read,Generic) instance FromRecord CsvTeam -- Заявка в CSV data CsvRequest = CsvRequest { crTown :: Text , crRepresentative :: Text , crNarrator :: Text , crStatus :: Text , crTeams :: Text } deriving (Eq,Show,Read,Generic) instance FromRecord CsvRequest -- | Получение списка заявок турнира -- -- Выполняет запрос на скачивание списка заявок в CSV и запрос на скачивание списка введённых команд в CSV -- -- Если второй запрос возвращает ошибку, список команд в заявке будет пустым и -- id представителя будет установлен в 0 (в CSV списка заявок его нет) -- -- Для некоторых турниров и некоторых заявок на сайте рейтинга утеряна -- информация о том, участие какого количества команд заявлялось. Для этих -- турниров поле 'reqTeamsCount' будет установлено в -1. -- -- Возвращаемые ошибки: -- -- * @No such tournament, returned html@ - неправильный идентификатор турнира -- -- * @Not a synch, or no requests yet@ - список заявок пуст; возникает, если турнир не является синхронным, или на него не было подано заявок -- -- * остальные ошибки могут возникнуть из-за сбоев сети и ввода-вывода requests :: TournamentId -- ^ Идентификатор турнира -> IO (Either B.ByteString [Request]) -- ^ Список заявок, либо ошибка requests (TournamentId t) = do let url1 = "http://rating.chgk.info/synch.php?download_data=requests_download&tournament_id=" ++ T.unpack t url2 = "http://rating.chgk.info/synch.php?download_data=teams_synch_data&tournament_id=" ++ T.unpack t r1 <- get url1 case r1 ^. responseStatus . statusCode of 200 -> do let ereqs = parseRequests (show t) $ r1 ^. responseBody r2 <- get url2 pure $ case r2 ^. responseStatus . statusCode of 200 -> let eteams = parseTeams $ r2 ^. responseBody in case ereqs of Left err -> case take 114 err of "parse error (Failed reading: conversion error: cannot unpack array of length 1 into a Only. Input record: [\"" -> Left "No such tournament, returned html" "parse error (not enough input) at \"\"" -> Left "Not a synch, or no requests yet" _ -> Left $ B.pack err Right reqs -> case eteams of Left _ -> Right reqs Right teams -> Right $ M.elems $ combineTeamsRequests teams reqs _ -> Left $ r2 ^. responseStatus . statusMessage _ -> pure $ Left $ r1 ^. responseStatus . statusMessage where combineTeamsRequests ts rs = M.merge M.preserveMissing M.preserveMissing (M.zipWithMatched combine) (mkMap ts) (mkMap rs) mkMap = M.fromList . map fromReq fromReq req@(Request{ reqTown = town, reqRepresentativeFullname = rep }) = ((town,rep), req) combine (town, repFullname) Request{ reqRepresentativeId = repId , reqTeams = teams } Request{ reqAccepted = acc , reqNarratorFullname = narFullname , reqTeamsCount = n } = Request { reqAccepted = acc , reqTown = town , reqRepresentativeId = repId , reqRepresentativeFullname = repFullname , reqNarratorId = 0 , reqNarratorFullname = narFullname , reqTeamsCount = n , reqTeams = teams } -- Разбор заявок из CSV сайта рейтинга parseRequests :: String -> ByteString -> Either String [Request] parseRequests tid bs = decodeWith csvOpts HasHeader (convert "CP1251" "UTF-8" bs) >>= mapM csvRequestToRequest . toList where csvRequestToRequest CsvRequest{ crTown = town , crRepresentative = repName , crNarrator = narName , crStatus = status , crTeams = cnt } = let n = either (const (-1)) fst $ decimal $ snd $ T.breakOnEnd " / " cnt in Right $ Request { reqAccepted = case status of "Принята" -> Just True "Отказано" -> Just False "Новая" -> Nothing _ -> error $ T.concat ["Unknown request status in ", T.pack tid, ": ", status] , reqTown = town , reqRepresentativeId = 0 , reqRepresentativeFullname = repName , reqNarratorId = 0 , reqNarratorFullname = narName , reqTeamsCount = n , reqTeams = [] } -- Разбор команд из CSV сайта рейтинга parseTeams :: ByteString -> Either String [Request] parseTeams = fmap (map csvTeamGroupToRequest . groupBy ((==)`on`ctRepId) . toList) . decodeWith csvOpts HasHeader . convert "CP1251" "UTF-8" where csvTeamGroupToRequest cs@(cr:_) = Request { reqAccepted = Nothing -- only on page , reqTown = ctTown cr , reqRepresentativeId = fromMaybe 0 $ ctRepId cr , reqRepresentativeFullname = T.concat [ ctRepSurname cr , " " , ctRepName cr , " " , ctRepPatronym cr ] , reqNarratorId = 0 -- only on page , reqNarratorFullname = "" -- only on page , reqTeamsCount = 0 -- only on page , reqTeams = map ctToTeam cs } csvTeamGroupToRequest [] = error "Impossible happened: [] in csvTeamGroupToRequest" ctToTeam CsvTeam { ctTeamId = ident , ctTeam = current , ctTeamTown = curTown , ctTeamBaseName = base , ctTeamBaseTown = baseTown } = TeamName ident current curTown base baseTown csvOpts :: DecodeOptions csvOpts = defaultDecodeOptions { decDelimiter = fromIntegral $ ord ';' } -- | Получает список предстоящих синхронов в городе -- -- @since 0.3.6.4 synchTown :: Int -- ^ Идентификатор города -> IO (Either B.ByteString [SynchTown]) -- ^ Ошибка или список синхронов в городе synchTown townId = do let url = "https://rating.chgk.info/jq_backend/synch.php?upcoming_synch=true&town_id=" ++ show townId -- TODO: better use: https://rating.chgk.info/synch_town/ r <- get url pure $ case r^.responseStatus.statusCode of 200 -> parseSynchTown $ r^.responseBody _ -> Left $ r^.responseStatus.statusMessage parseSynchTown :: ByteString -> Either B.ByteString [SynchTown] parseSynchTown body = let tags = parseTags $ convert "CP1251" "UTF-8" body :: [Tag ByteString] tbodyTagName = "tbody" :: ByteString tbody = takeWhile (\t -> t ~/= TagClose tbodyTagName) $ dropWhile (\t -> t ~/= TagOpen tbodyTagName []) $ mapMaybe trimTags tags trName = "tr" :: ByteString tdName = "td" :: ByteString cols = map (partitions (\t -> t ~== TagOpen tdName [])) $ partitions (\t -> t ~== TagOpen trName []) tbody in mapM parseSynchTownRow cols trimTags :: Tag ByteString -> Maybe (Tag ByteString) trimTags (TagText t) = case BL.dropWhile isSpace t of "" -> Nothing u -> Just $ TagText $ BL.reverse $ BL.dropWhile isSpace $ BL.reverse u trimTags t = Just t parseSynchTownRow :: [[Tag ByteString]] -> Either B.ByteString SynchTown parseSynchTownRow [syn, stat, rep, time] = do let listToEither s [] = Left s listToEither _ (x:_) = Right x toClaimStatus "Заявка не рассмотрена" = Right ClaimNew toClaimStatus "Заявка принята" = Right ClaimAccepted toClaimStatus "Заявка отклонена" = Right ClaimRejected toClaimStatus s = Left $ B.pack $ "Wrong claim status " ++ T.unpack s synHref <- fmap (TournamentId . decodeUtf8 . BL.drop 12 . fromAttrib "href") $ listToEither "Can't find href for synch id in synchTown" $ filter (isTagOpenName "a") syn synText <- fmap (decodeUtf8 . fromTagText) $ listToEither "Can't find synch name in synchTown" $ filter isTagText syn statI <- fmap (decodeUtf8 . fromAttrib "title") $ listToEither "Can't find i for status in synchTown" $ filter (isTagOpenName "i") stat status <- toClaimStatus statI repHref <- fmap (PlayerId . decodeUtf8 . BL.drop 8 . fromAttrib "href") $ listToEither "Can't find href for rep id in synchTown" $ filter (isTagOpenName "a") rep repName <- fmap (decodeUtf8 . fromTagText) $ listToEither "Can't find rep name in synchTown" $ filter isTagText rep timeText <- fmap (decodeUtf8 . fromTagText) $ listToEither "Can't find time in synchTown" $ filter isTagText time tim <- parseTimeText timeText pure $ SynchTown synHref synText status repHref repName tim parseSynchTownRow _ = Left "Html changed in synchTown, please report to chgk@pm.me" parseTimeText :: Text -> Either B.ByteString LocalTime parseTimeText t = case T.words t of [dStr,monStr,yStr,timeStr] -> case T.split (==':') timeStr of [hStr,mStr,sStr] -> do d <- eparse "Can't parse day" dStr mon<-emonth monStr y <- eparse "Can't parse year" yStr h <- eparse "Can't parse hour" hStr m <- eparse "Can't parse min" mStr s <- eparse "Can't parse sec" sStr pure $ LocalTime (fromGregorian y mon d) (TimeOfDay h m $ MkFixed $ s * (resolution (MkFixed 0 :: Pico))) _ -> Left "Can't parse time" _ -> Left "Can't parse date" where eparse e t = case decimal t of Left _ -> Left e Right (n,_) -> Right n emonth m = case elemIndex m months of Nothing -> Left "Can't parse month" Just v -> Right $ v+1 months = ["января", "февраля", "марта", "апреля", "мая", "июня", "июля", "августа", "сентября", "октября", "ноября", "декабря"] -- | Получает список городов -- -- @since 0.3.6.4 towns :: Maybe Int -- ^ Номер страницы (если не задан - первая) -> IO (Either B.ByteString [Town]) -- ^ Ошибка или список городов towns mpage = do let url = "https://rating.chgk.info/geo.php?layout=town_list" ++ maybe "" (("&page=" ++) . show) mpage r <- get url pure $ case r^.responseStatus.statusCode of 200 -> parseTown $ r^.responseBody _ -> Left $ r^.responseStatus.statusMessage parseTown :: ByteString -> Either B.ByteString [Town] parseTown body = let tags = parseTags $ convert "CP1251" "UTF-8" body :: [Tag ByteString] tbodyTagName = "tbody" :: ByteString tbody = takeWhile (\t -> t ~/= TagClose tbodyTagName) $ dropWhile (\t -> t ~/= TagOpen tbodyTagName []) $ mapMaybe trimTags tags trName = "tr" :: ByteString tdName = "td" :: ByteString cols = map (partitions (\t -> t ~== TagOpen tdName [])) $ partitions (\t -> t ~== TagOpen trName []) tbody in mapM parseTownRow cols parseTownRow :: [[Tag ByteString]] -> Either B.ByteString Town parseTownRow [identT, nameT, regionT, countryT, _countT] = do let listToEither s [] = Left s listToEither _ (x:_) = Right x toId c t = case decimal t of Left e -> Left $ B.pack e Right (n,_) -> Right $ c n identText <- fmap (decodeUtf8 . fromTagText) $ listToEither "Can't find ident in towns" $ filter isTagText identT ident <- toId id identText let (townT, otherT) = span (\t -> t ~/= TagOpen ("span" :: ByteString) []) nameT town <- fmap (decodeUtf8 . fromTagText) $ listToEither "Can't find town in towns" $ filter isTagText townT other <- case filter (isTagOpenName "a") otherT of [] -> Right Nothing (t:_) -> Right $ Just $ decodeUtf8 $ fromAttrib "title" t region <- case filter isTagText regionT of [] -> Right Nothing (t:_) -> Right $ Just $ decodeUtf8 $ fromTagText t country <- case filter isTagText countryT of [] -> Right Nothing (t:_) -> Right $ Just $ decodeUtf8 $ fromTagText t pure $ Town ident town other region country parseTownRow _ = Left "Html changed in synchTown, please report to chgk@pm.me"