rating-chgk-info-0.3.6.3: src/RatingChgkInfo/NoApi.hs
{-|
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: [\"<html>" ->
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 ';'
}