diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -11,7 +11,24 @@ ## Fixed ## Security -# 0.3.6.3 +# 0.3.6.4 - 2019-04-09 + +## Added + +* Получение всех составов на турнире (API 3.6.4) +* Поиск по турнирам (API 3.6.4) +* Получение списка городов +* Получение ближайших синхронов в городе +* Приложение для генерации календарей синхронов в городе (app/calendar-rating) + +## Changed + +* Поля `archive` и `date_archived_at` в турнирах (API 3.6.4) +* Исправлены версии зависимостей, теперь они совместимы с GHC 8.6 +* Работает с servant 0.16 +* Данные запрашиваются через https + +# 0.3.6.3 - 2019-02-09 ## Added diff --git a/app/calendar-rating/Main.hs b/app/calendar-rating/Main.hs new file mode 100644 --- /dev/null +++ b/app/calendar-rating/Main.hs @@ -0,0 +1,104 @@ +{-# LANGUAGE OverloadedStrings #-} + +import RatingChgkInfo +import RatingChgkInfo.Types.Unsafe (TournamentId (..), PlayerId (..)) + +import Data.Aeson +import Data.Text (Text) +import qualified Data.Text as T +import qualified Data.Text.IO as T +import Data.Time +import System.Directory (withCurrentDirectory) +import System.Environment (getArgs) + +main :: IO () +main = do + args <- getArgs + case args of + [rootDir, "town", townStr, town] -> withCurrentDirectory rootDir $ + case readMaybe townStr of + Nothing -> usage + Just townId -> workTown townId (T.pack town) Nothing >>= mapM_ print + [rootDir, townPagesStr] -> withCurrentDirectory rootDir $ + case readMaybe townPagesStr of + Nothing -> usage + Just townPages -> work townPages + _ -> usage + +usage :: IO () +usage = do + die "Usage: calendar-rating " + +work :: Int -> IO () +work townPages = do + ets <- fmap (fmap concat . sequence) $ forM [1..townPages] $ towns . Just + case ets of + Left err -> T.putStrLn $ decodeUtf8 err + Right ts -> do + ss <- forM ts $ \Town{ townId = ident, townName = town, townOtherName = other } -> do + T.putStrLn town + workTown ident town other + encodeFile "names.json" $ + map fst $ + filter (not . null . snd) $ + zip ts ss + +workTown :: Int -> Text -> Maybe Text -> IO [SynchTown] +workTown ident town other = do + now <- getCurrentTime + ests <- synchTown ident + case ests of + Left err -> T.putStrLn (decodeUtf8 err) >> pure [] + Right sts -> do + let fname = "t" ++ show ident ++ ".ics" + let events = filter ((==ClaimAccepted) . stStatus) sts + unless (null events) $ + T.writeFile fname $ T.intercalate "\r\n" + [ calStart + , T.intercalate "\r\n" $ + map (mkEvent now town other) events + , calEnd + ] + pure events + +calStart :: Text +calStart = T.intercalate "\r\n" + [ "BEGIN:VCALENDAR" + , "VERSION:2.0" + , "PRODID:-//calendar.chgk.me/EN" + , "METHOD:PUBLISH" + ] + +calEnd :: Text +calEnd = "END:VCALENDAR" + +mkEvent :: UTCTime -> Text -> Maybe Text -> SynchTown -> Text +mkEvent now town other SynchTown{ stTournamentId = TournamentId tid + , stTournament = tourn + , stRepresentativeId = PlayerId rid + , stRepresentative = rep + , stTime = time } + = T.intercalate "\r\n" + [ "BEGIN:VEVENT" + , "UID:" `T.append` uid + , "DTSTAMP:" `T.append` ts + , "DTSTART;TZID=Europe/Moscow:" `T.append` start + , "SUMMARY:" `T.append` summary + , "ORGANIZER:" `T.append` org + , "LOCATION:" `T.append` loc + , "URL:" `T.append` url + , "DESCRIPTION:" `T.append` desc + , "END:VEVENT" + ] + where + uid = T.concat [ "t", tid, "-r", rid, "@calendar.chgk.me" ] + format :: FormatTime t => t -> Text + format = T.pack . formatTime defaultTimeLocale "%Y%m%dT%H%M%S" + ts = format now `T.append` "Z" + start = format time + summary = tourn + org = rep + loc = T.concat $ town : maybe [] pure other + url = T.concat [ "https://rating.chgk.info/tournament/", tid ] + desc = T.concat [ "Представитель: ", rep, "\\n", "Турнир: ", url] + diff --git a/rating-chgk-info.cabal b/rating-chgk-info.cabal --- a/rating-chgk-info.cabal +++ b/rating-chgk-info.cabal @@ -1,6 +1,6 @@ cabal-version: 1.24 name: rating-chgk-info -version: 0.3.6.3 +version: 0.3.6.4 synopsis: Client for rating.chgk.info API and CSV tables (documentation in Russian) description: Клиент для REST API сайта рейтинга (rating.chgk.info) и функциональности, которой нет в REST API, но которая доступна через экспорт CSV. @@ -80,23 +80,25 @@ -fhide-source-paths -Wmissing-export-lists -Wpartial-fields - build-depends: base-noprelude == 4.11.* + build-depends: base-noprelude >= 4.11 , relude >= 0.4.0 , aeson >=1.4 , bytestring >=0.10 , cassava >=0.5 , containers >=0.5 , http-client >= 0.5 + , http-client-tls >= 0.3 , iconv >=0.4 , lens >=4.17 , network >=2.8 , optparse-generic >=1.3 - , servant >=0.15 - , servant-client >=0.15 + , servant >=0.16 + , servant-client >=0.16 , servant-js >=0.9 - , servant-server >=0.15 + , servant-server >=0.16 , servant-swagger >=1.1 , swagger2 >=2.2 + , tagsoup >=0.14 , text >=1.2 , time >=1.8 , vector >=0.12 @@ -166,6 +168,30 @@ build-depends: base-noprelude , rating-chgk-info , relude + default-language: Haskell2010 + +executable calendar-rating + hs-source-dirs: app/calendar-rating + main-is: Main.hs + ghc-options: -Wall + -threaded + -rtsopts + -with-rtsopts=-N + -Wincomplete-uni-patterns + -Wincomplete-record-updates + -Wcompat + -Widentities + -Wredundant-constraints + -fhide-source-paths + -Wmissing-export-lists + -Wpartial-fields + build-depends: base-noprelude + , rating-chgk-info + , relude + , aeson + , directory + , text + , time default-language: Haskell2010 diff --git a/src/RatingChgkInfo/Api.hs b/src/RatingChgkInfo/Api.hs --- a/src/RatingChgkInfo/Api.hs +++ b/src/RatingChgkInfo/Api.hs @@ -57,6 +57,7 @@ , tournamentResultsCountry , tournamentTeamResult -- ** Составы на турнире + , tournamentRecaps , tournamentRecap -- ** Спорные и апелляции , tournamentControversials @@ -66,13 +67,15 @@ -- $maybeParams , teamSearch , playerSearch + , tournamentSearch -- * Вспомогательные функции , getAllItems ) where import RatingChgkInfo.Types -import Network.HTTP.Client (newManager,defaultManagerSettings) +import Network.HTTP.Client (newManager) +import Network.HTTP.Client.TLS (tlsManagerSettings) import Servant.API import Servant.Client @@ -80,157 +83,235 @@ api = Proxy -- | Список всех игроков +-- +-- Запрос @\/players@ players :: Maybe Int -- ^ Номер страницы в результате -> RatingClient (Items Player) -- ^ Список игроков, по 1000 элементов -- | Информация об игроке -- -- __API NOTE__. Результат должен быть 'Player', а не список игроков из одного элемента +-- +-- Запрос @\/players\/:id@ player :: PlayerId -- ^ Идентификатор игрока -> RatingClient [Player] -- ^ Информация об игроке, список из единственного элемента -- | Команды, в базовых составах которых играл игрок +-- +-- Запрос @\/players\/:id\/teams@ playerTeams :: PlayerId -- ^ Идентификатор игрока -> RatingClient [PlayerTeam] -- ^ Список команд игрока -- | Команды, в базовый состав которых игрок входит в текущем сезоне +-- +-- Запрос @\/players\/:id\/teams\/last@ playerLastTeam :: PlayerId -- ^ Идентификатор игрока -> RatingClient [PlayerTeam] -- ^ Список команд игрока -- | Команды, в базовый состав которых игрок входил в указанном сезоне +-- +-- Запрос @\/players\/:id\/teams\/:season@ playerTeam :: PlayerId -- ^ Идентификатор игрока -> Int -- ^ Идентификатор сезона -> RatingClient [PlayerTeam] -- ^ Список команд игрока -- | Турниры, которые отыграл игрок, по сезонам +-- +-- Запрос @\/players\/:id\/tournaments@ playerTournaments :: PlayerId -- ^ Идентификатор игрока -> RatingClient (SeasonMap PlayerSeason) -- ^ Турниры игрока по сезонам -- | Турниры, которые игрок отыграл в текущем сезоне +-- +-- Запрос @\/players\/:id\/tournaments\/last@ playerLastTournament :: PlayerId -- ^ Идентификатор игрока -> RatingClient PlayerSeason -- | Турниры, которые игрок отыграл в указанном сезоне +-- +-- Запрос @\/players\/:id\/tournaments\/:season@ playerTournament :: PlayerId -- ^ Идентификатор игрока -> Int -- ^ Идентификатор сезона -> RatingClient PlayerSeason -- | Рейтинги игрока +-- +-- Запрос @\/players\/:id\/rating@ playerRatings :: PlayerId -- ^ Идентификатор игрока -> RatingClient [PlayerRating] -- ^ Список рейтингов игрока, порядок не определён -- | Рейтинг игрока в последнем релизе -- -- __API NOTE__. Работает не всегда: например, для 54345 в декабре 2018 ничего не возвращало (off-by-one error?) +-- +-- Запрос @\/players\/:id\/rating\/last@ playerLastRating :: PlayerId -- ^ Идентификатор игрока -> RatingClient PlayerRating -- | Рейтинг игрока в указанном релизе +-- +-- Запрос @\/players\/:id\/rating\/:release@ playerRating :: PlayerId -- ^ Идентификатор игрока -> Int -- ^ Идентификатор релиза -> RatingClient PlayerRating -- | Список всех команд +-- +-- Запрос @\/teams@ teams :: Maybe Int -- ^ Номер страницы в результате -> RatingClient (Items Team) -- ^ Команды по 1000 элементов -- | Информация о команде -- -- __API NOTE__: должна быть команда, а не список из команд +-- +-- Запрос @\/teams\/:id@ team :: TeamId -- ^ Идентификатор команды -> RatingClient [Team] -- ^ Команда, список из единственного элемента -- | Базовые составы команды +-- +-- Запрос @\/teams\/:id\/recaps@ teamBaseRecaps :: TeamId -- ^ Идентификатор команды -> RatingClient (SeasonMap TeamBaseRecap) -- ^ Базовые составы по сезонам -- | Базовый состав команды в последнем сезоне +-- +-- Запрос @\/teams\/:id\/recaps\/last@ teamLastBaseRecap :: TeamId -- ^ Идентификатор команды -> RatingClient TeamBaseRecap -- | Базовый состав команды в указанном сезоне +-- +-- Запрос @\/teams\/:id\/recaps\/:season@ teamBaseRecap :: TeamId -- ^ Идентификатор команды -> Int -- ^ Идентификатор сезона -> RatingClient TeamBaseRecap -- | Турниры, отыгранные командой +-- +-- Запрос @\/teams\/:id\/tournaments@ teamTournaments :: TeamId -- ^ Идентификатор команды -> RatingClient (SeasonMap TeamTournament) -- ^ Турниры команды по сезонам -- | Турниры, отыгранные командой в последнем сезоне +-- +-- Запрос @\/teams\/:id\/tournaments\/last@ teamLastTournament :: TeamId -- ^ Идентификатор команды -> RatingClient TeamTournament -- | Турниры, отыгранные командой в указанном сезоне +-- +-- Запрос @\/teams\/:id\/tournaments\/:season@ teamTournament :: TeamId -- ^ Идентификатор команды -> Int -- ^ Идентификатор сезона -> RatingClient TeamTournament -- | Рейтинги команды +-- +-- Запрос @\/teams\/:id\/rating@ teamRatings :: TeamId -- ^ Идентификатор команды -> RatingClient [TeamRating] -- ^ Список рейтингов команды, порядок не определён -- | Последний рейтинг команды по формуле A -- -- __API NOTE__. Работает не всегда: для 1 ничего не возвращает (off-by-one error?) +-- +-- Запрос @\/teams\/:id\/rating\/a@ teamRatingA :: TeamId -- ^ Идентификатор команды -> RatingClient TeamRating -- | Последний рейтинг команды по формуле B -- -- __API NOTE__. Работает не всегда: для 1 ничего не возвращает (off-by-one error?) +-- +-- Запрос @\/teams\/:id\/rating\/b@ teamRatingB :: TeamId -- ^ Идентификатор команды -> RatingClient TeamRating -- | Рейтинг команды в указанном релизе +-- +-- Запрос @\/teams\/:id\/rating\/:release@ teamRating :: TeamId -- ^ Идентификатор команды -> Int -- ^ Идентификатор релиза -> RatingClient TeamRating -- | Список всех турниров -tournaments :: Maybe Int -- ^ Номер страницы в результате +-- +-- Запрос @\/tournaments@ +tournaments :: Maybe Int -- ^ Номер страницы (@page@) в результате -> RatingClient (Items TournamentShort) -- ^ Информация о турнирах по 1000 элементов -- | Информация о турнире -- -- __API NOTE__: должен быть турнир, а не список турниров +-- +-- Запрос @\/tournaments\/:id@ tournament :: TournamentId -- ^ Идентификатор турнира -> RatingClient [Tournament] -- ^ Единственный элемент списка - турнир -- | Результаты турнира +-- +-- Запрос @\/tournaments\/:id\/list@ tournamentResults :: TournamentId -- ^ Идентификатор турнира -> RatingClient [TournamentResult] -- ^ Результаты по командам, порядок не определён -- | Результаты турнира для команд города +-- +-- Запрос @\/tournaments\/:id\/list\/town\/:town@ tournamentResultsTown :: TournamentId -- ^ Идентификатор турнира -> Int -- ^ Идентификатор города -> RatingClient [TournamentResult] -- ^ Результаты по командам, порядок не определён -- | Результаты турнира для команд региона +-- +-- Запрос @\/tournaments\/:id\/list\/region\/:region@ tournamentResultsRegion :: TournamentId -- ^ Идентификатор турнира -> Int -- ^ Идентификатор региона -> RatingClient [TournamentResult] -- ^ Результаты по командам, порядок не определён -- | Результаты турнира для команд страны +-- +-- Запрос @\/tournaments\/:id\/list\/country\/:country@ tournamentResultsCountry :: TournamentId -- ^ Идентификатор турнира -> Int -- ^ Идентификатор страны -> RatingClient [TournamentResult] -- ^ Результаты по командам, порядок не определён +-- | Составы команд на турнире +-- +-- Запрос @\/tournaments\/:id\/recaps@ +-- +-- @since 0.3.6.4 +tournamentRecaps :: TournamentId -- ^ Идентификаторр турнира + -> RatingClient [RecapTeam] + -- | Составы указанной команды на турнире +-- +-- Запрос @\/tournaments\/:id\/recaps\/:team@ tournamentRecap :: TournamentId -- ^ Идентификатор турнира -> TeamId -- ^ Идентификатор команды -> RatingClient [RecapPlayer] -- ^ Список игроков с флагами К\/Б\/Л -- | Результат указанной команды на турнире +-- +-- Запрос @\/tournaments\/:id\/results\/:team@ tournamentTeamResult :: TournamentId -- ^ Идентификатор турнира -> TeamId -- ^ Идентификатор команды -> RatingClient [TourResult] -- ^ Список результатов по турам -- | Спорные на турнире +-- +-- Запрос @\/tournaments\/:id\/controversials@ +-- +-- @since 0.3.6.3 tournamentControversials :: TournamentId -- ^ Идентификатор турнира -> RatingClient [Controversial] -- ^ Спорные -- | Апелляции на турнире +-- +-- Запрос @\/tournaments\/:id\/appeals@ +-- +-- @since 0.3.6.3 tournamentAppeals :: TournamentId -- ^ Идентификатор турнира -> RatingClient [Appeal] -- ^ Апелляции @@ -242,6 +323,8 @@ -- связки И. -- | Поиск по командам +-- +-- Запрос @\/teams\/search@ teamSearch :: Maybe Text -- ^ Название (name) -> Maybe Text -- ^ Город (town) -> Maybe Text -- ^ Регион (region_name) @@ -251,14 +334,24 @@ -> RatingClient (Items Team) -- ^ Список команд по 1000 элементов -- | Поиск по игрокам +-- +-- Запрос @\/players\/search@ playerSearch :: Maybe Text -- ^ Фамилия -> Maybe Text -- ^ Имя -> Maybe Text -- ^ Отчество -> Maybe Int -- ^ Номер страницы в результате -> RatingClient (Items Player) -- ^ Список игроков по 1000 элементов -players :<|> player :<|> playerTeams :<|> playerLastTeam :<|> playerTeam :<|> playerTournaments :<|> playerLastTournament :<|> playerTournament :<|> playerRatings :<|> playerLastRating :<|> playerRating :<|> teams :<|> team :<|> teamBaseRecaps :<|> teamLastBaseRecap :<|> teamBaseRecap :<|> teamTournaments :<|> teamLastTournament :<|> teamTournament :<|> teamRatings :<|> teamRatingA :<|> teamRatingB :<|> teamRating :<|> tournaments :<|> tournament :<|> tournamentResults :<|> tournamentResultsTown :<|> tournamentResultsRegion :<|> tournamentResultsCountry :<|> tournamentRecap :<|> tournamentTeamResult :<|> tournamentControversials :<|> tournamentAppeals :<|> teamSearch :<|> playerSearch = client api +-- | Поиск по турнирам +-- +-- Запрос @\/tournaments\/search@ +tournamentSearch :: Maybe TournamentType -- ^ Тип турнира + -> Maybe Int -- ^ Находится ли турнир в архиве (0 - не находится, 1 - находится) + -> Maybe Int -- ^ Номер страницы в результате + -> RatingClient (Items TournamentShort) +players :<|> player :<|> playerTeams :<|> playerLastTeam :<|> playerTeam :<|> playerTournaments :<|> playerLastTournament :<|> playerTournament :<|> playerRatings :<|> playerLastRating :<|> playerRating :<|> teams :<|> team :<|> teamBaseRecaps :<|> teamLastBaseRecap :<|> teamBaseRecap :<|> teamTournaments :<|> teamLastTournament :<|> teamTournament :<|> teamRatings :<|> teamRatingA :<|> teamRatingB :<|> teamRating :<|> tournaments :<|> tournament :<|> tournamentResults :<|> tournamentResultsTown :<|> tournamentResultsRegion :<|> tournamentResultsCountry :<|> tournamentRecaps :<|> tournamentRecap :<|> tournamentTeamResult :<|> tournamentControversials :<|> tournamentAppeals :<|> teamSearch :<|> playerSearch :<|> tournamentSearch = client api + -- | Получение всех элементов из запроса с разбиением по страницам -- -- В функции предполагается, что сайт рейтинга, как и указано в документации, @@ -275,8 +368,8 @@ -- -- Все запросы внутри 'RatingClient' используют один и тот же менеджер соединений runRatingApi :: RatingClient a -- ^ Набор команд, работающих с API сайта рейтинга - -> IO (Either ServantError a) -- ^ Результат работы, либо ошибка + -> IO (Either ClientError a) -- ^ Результат работы, либо ошибка runRatingApi act = do - mgr <- newManager defaultManagerSettings - runClientM act $ mkClientEnv mgr $ BaseUrl Http "rating.chgk.info" 80 "api" + mgr <- newManager tlsManagerSettings + runClientM act $ mkClientEnv mgr $ BaseUrl Https "rating.chgk.info" 443 "api" diff --git a/src/RatingChgkInfo/NoApi.hs b/src/RatingChgkInfo/NoApi.hs --- a/src/RatingChgkInfo/NoApi.hs +++ b/src/RatingChgkInfo/NoApi.hs @@ -17,25 +17,32 @@ module RatingChgkInfo.NoApi ( requests + , synchTown + , towns ) where import Prelude hiding (ByteString, get) import RatingChgkInfo.Types -import RatingChgkInfo.Types.Unsafe (TournamentId (..)) +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 @@ -191,4 +198,142 @@ 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" diff --git a/src/RatingChgkInfo/Types.hs b/src/RatingChgkInfo/Types.hs --- a/src/RatingChgkInfo/Types.hs +++ b/src/RatingChgkInfo/Types.hs @@ -47,12 +47,17 @@ , TeamTournament(..) , TeamRating(..) -- ** Турнир + -- *** Общая информация о турнире , TournamentShort(..) , Tournament(..) , tournamentToShort - , TournamentResult(..) + -- *** Составы + , RecapTeam(..) , RecapPlayer(..) + -- *** Результаты + , TournamentResult(..) , TourResult(..) + -- *** Спорные и апелляции , Controversial (..) , Appeal (..) -- ** Типы-перечисления @@ -81,8 +86,13 @@ -- -- Функции для работы с этими типами находятся в модуле "RatingChgkInfo.NoApi" -- + -- ** Заявки на турниры , Request(..) , TeamName(..) + -- ** География + , Town (..) + -- ** Синхроны в городе + , SynchTown(..) ) where import RatingChgkInfo.Types.Unsafe @@ -313,6 +323,10 @@ toJSON tt = toJSON $ fromMaybe (error "Not all tournamentTypes have names") $ lookup tt tournamentTypenames toEncoding tt = toEncoding $ fromMaybe (error "Not all tournamentTypes have names") $ lookup tt tournamentTypenames +instance ToHttpApiData TournamentType where + toUrlPiece tt = toUrlPiece $ fromMaybe (error "Not all tournamentTypes have names") $ lookup tt tournamentTypenames + toQueryParam tt = toQueryParam $ fromMaybe (error "Not all tournamentTypes have names") $ lookup tt tournamentTypenames + -- | Короткая информация о турнире (в списке турниров) data TournamentShort = TournamentShort { trs_idtournament :: TournamentId -- ^ Идентификатор турнира. __API NOTE__: должен быть Int @@ -320,6 +334,14 @@ , trs_dateStart :: LocalTime -- ^ Дата начала турнира (в часовом поясе МСК) , trs_dateEnd :: LocalTime -- ^ Дата окончания турнира (в часовом поясе МСК) , trs_typeName :: TournamentType -- ^ Тип турнира + , trs_archive :: Text + -- ^ Архивирован ли турнир (0 - нет, 1 - да, пустая строка - турнир слишком давний). __API NOTE__: должен быть Bool + -- + -- @since 0.3.6.4 + , trs_dateArchivedAt :: Day + -- ^ Дата занесения в архив (может быть пустая строка). __API NOTE__: должен быть Maybe UTCTime + -- + -- @since 0.3.6.4 } deriving (Eq,Show,Read,Generic) instance FromJSON TournamentShort where @@ -362,6 +384,14 @@ , trn_dateRequestsAllowedTo :: Text -- ^ Дата, до которой разрешена подача заявок. __API NOTE__: должен быть Day , trn_comment :: Text -- ^ Комментарий (это __не__ текст внизу на странице турнира; например, в турнире 5003 комментарий пуст, хотя текст внизу гласит «Сроки турнира привязаны к Новому году и финалу года телеЧГК») , trn_siteUrl :: Text -- ^ Адрес официального сайта + , trn_archive :: Text + -- ^ Архивирован ли турнир (0 - нет, 1 - да, пустая строка - турнир слишком давний). __API NOTE__: должен быть Bool + -- + -- @since 0.3.6.4 + , trn_dateArchivedAt :: Day + -- ^ Дата занесения в архив (может быть пустая строка). __API NOTE__: должен быть Maybe UTCTime + -- + -- @since 0.3.6.4 } deriving (Eq,Show,Read,Generic) instance FromJSON Tournament where @@ -377,12 +407,16 @@ , trn_dateStart = dateStart , trn_dateEnd = dateEnd , trn_typeName = typeName + , trn_archive = archive + , trn_dateArchivedAt = dateArchived } = TournamentShort { trs_idtournament = idtournament , trs_name = name , trs_dateStart = dateStart , trs_dateEnd = dateEnd , trs_typeName = typeName + , trs_archive = archive + , trs_dateArchivedAt = dateArchived } -- | Результаты турнира для команды @@ -409,7 +443,7 @@ -- | Информация об игроке в составе команды на турнире -- --- __API NOTE__. Так как игрок не может быть одновременно в базовом составе и легионером, нужно заменить эти два поля одним. +-- __API NOTE__. Так как игрок не может быть одновременно в базовом составе и легионером, нужно заменить эти два поля одним, либо описать, когда игрок может не быть ни базовым, ни легионером data RecapPlayer = RecapPlayer { rp_idplayer :: PlayerId -- ^ Идентификатор игрока. __API NOTE__: должен быть Int , rp_is_captain :: Text -- ^ Является ли игрок капитаном (К). __API NOTE__: должен быть Bool @@ -423,6 +457,18 @@ toJSON = genericToJSON $ jsonOpts '_' 3 toEncoding = genericToEncoding $ jsonOpts '_' 3 +-- | Состав команды на турнире +data RecapTeam = RecapTeam + { rt_idteam :: TeamId -- ^ Идентификатор команды. __API NOTE__: должен быть Int + , rt_recaps :: [RecapPlayer] -- ^ Состав команды + } deriving (Eq,Show,Read,Generic) + +instance FromJSON RecapTeam where + parseJSON = genericParseJSON $ jsonOpts '_' 3 +instance ToJSON RecapTeam where + toJSON = genericToJSON $ jsonOpts '_' 3 + toEncoding = genericToEncoding $ jsonOpts '_' 3 + -- | Результаты команды по турам data TourResult = TourResult { tor_tour :: Text -- ^ Номер тура. __API NOTE__: должен быть Int @@ -564,12 +610,14 @@ :<|> "tournaments" :> Capture "idtournament" TournamentId :> "list" :> "town" :> Capture "idtown" Int :> Get '[JSON] [TournamentResult] :<|> "tournaments" :> Capture "idtournament" TournamentId :> "list" :> "region" :> Capture "idregion" Int :> Get '[JSON] [TournamentResult] :<|> "tournaments" :> Capture "idtournament" TournamentId :> "list" :> "country" :> Capture "idcountry" Int :> Get '[JSON] [TournamentResult] + :<|> "tournaments" :> Capture "idtournament" TournamentId :> "recaps" :> Get '[JSON] [RecapTeam] :<|> "tournaments" :> Capture "idtournament" TournamentId :> "recaps" :> Capture "idteam" TeamId :> Get '[JSON] [RecapPlayer] -- TODO: Set? :<|> "tournaments" :> Capture "idtournament" TournamentId :> "results" :> Capture "idteam" TeamId :> Get '[JSON] [TourResult] :<|> "tournaments" :> Capture "idtournament" TournamentId :> "controversials" :> Get '[JSON] [Controversial] :<|> "tournaments" :> Capture "idtournament" TournamentId :> "appeals" :> Get '[JSON] [Appeal] :<|> "teams" :> "search" :> QueryParam "name" Text :> QueryParam "town" Text :> QueryParam "region_name" Text :> QueryParam "country_name" Text :> QueryFlag "active_this_season" :> QueryParam "page" Int :> Get '[JSON] (Items Team) :<|> "players" :> "search" :> QueryParam "surname" Text :> QueryParam "name" Text :> QueryParam "patronymic" Text :> QueryParam "page" Int :> Get '[JSON] (Items Player) + :<|> "tournaments" :> "search" :> QueryParam "type_name" TournamentType :> QueryParam "archive" Int :> QueryParam "page" Int :> Get '[JSON] (Items TournamentShort) -------------------------------------------------------------------------------- -- Non-API Types @@ -612,6 +660,36 @@ declareNamedSchema p = genericDeclareNamedSchema (schemaOpts 3) p & mapped.schema.title ?~ "Request" & mapped.schema.description ?~ "Заявка. В объекте содержатся поля accepted - статус заявки (null - не рассмотрена, false/true - отклонена или принята); town - город; representative-id - id представителя; representative-fullname - ФИО представителя, narrator-id - id ведущего (сейчас установлена в 0, сайт рейтинга не экспортирует id); narrator-fullname - ФИО ведущего; teams-count - примерное количество команд (заявлено); teams - список введённых команд" + +-- | Синхрон, проводимый в городе +data SynchTown = SynchTown + { stTournamentId :: TournamentId -- ^ Идентификатор турнира + , stTournament :: Text -- ^ Название турнира + , stStatus :: ClaimStatus -- ^ Статус заявки + , stRepresentativeId :: PlayerId -- ^ Идентификатор представителя + , stRepresentative :: Text -- ^ ФИО представителя + , stTime :: LocalTime -- ^ Время проведения + } deriving (Eq,Show,Read,Generic) + +instance ToJSON SynchTown where + toJSON = genericToJSON $ jsonOpts '-' 2 + toEncoding = genericToEncoding $ jsonOpts '-' 2 + +-- | Идентификатор города +type TownId = Int + +-- | Город +data Town = Town + { townId :: TownId -- ^ Идентификатор города + , townName :: Text -- ^ Название города + , townOtherName :: Maybe Text -- ^ Альтернативное название города (например, Бахмут - Артёмовск) + , townRegion :: Maybe Text -- ^ Регион + , townCountry :: Maybe Text -- ^ Страна + } deriving (Eq,Show,Read,Generic) + +instance ToJSON Town where + toJSON = genericToJSON $ jsonOpts '-' 4 + toEncoding = genericToEncoding $ jsonOpts '-' 4 jsonOpts :: Char -> Int -> Options jsonOpts c k = defaultOptions { fieldLabelModifier = camelTo2 c . drop k }