{-| 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 ) where import Prelude hiding (ByteString, get) import RatingChgkInfo.Types import RatingChgkInfo.Types.Unsafe (TournamentId (..)) import Codec.Text.IConv import Control.Lens import qualified Data.ByteString.Char8 as B import Data.ByteString.Lazy.Char8 (ByteString) import Data.Csv 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 Network.Wreq -- Команда в 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 ';' }