diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,49 @@ +# Change log + +`rating-chgk-info` uses [PVP Versioning][1]. + +# Unreleased + +## Added +## Changed +## Removed +## Deprecated +## Fixed +## Security + +# 0.3.6.3 + +## Added + +* Функции для работы со спорными и апелляциями (версия API 3.6.3) +* Поле `tournament_in_rating`, показывающее, учитывается ли турнир в рейтинге (API 3.6.3) +* Примеры работы с библиотекой + +## Changed + +* Каждый идентификатор (игрока, команды, релиза и т.п.) имеет свой тип +* Модуль `RatingChgkInfo` экспортирует весь необходимый код + +## Removed + +* Функция `apiIdToInt`, поскольку теперь каждый идентификатор имеет свой тип + +## Fixed + +* Добавлен workaround: на сайте рейтинга для некоторых турниров и заявок утеряны + данные о количестве изначально заявленных команд + +# 0.2.1.0 + +## Added + +* Клиентские функции для REST API сайта рейтинга (на 2019-01-13, версия 3.6.2, обновление движка 22-10-2018 01:48) +* Получение данных о заявках и введённых командах через CSV +* REST-сервер для заявок + +# 0.0.0 + +* Initially created. + +[1]: https://pvp.haskell.org + diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,29 @@ +BSD 3-Clause License + +Copyright (c) 2018, Mansur Ziiatdinov +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + +* Redistributions of source code must retain the above copyright notice, this + list of conditions and the following disclaimer. + +* Redistributions in binary form must reproduce the above copyright notice, + this list of conditions and the following disclaimer in the documentation + and/or other materials provided with the distribution. + +* Neither the name of the copyright holder nor the names of its + contributors may be used to endorse or promote products derived from + this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" +AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE +IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE +DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE +FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR +SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER +CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, +OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,68 @@ +# rating-chgk-info + +[![Hackage](https://img.shields.io/hackage/v/rating-chgk-info.svg)](https://hackage.haskell.org/package/rating-chgk-info) +[![BSD3 license](https://img.shields.io/badge/license-BSD3-blue.svg)](LICENSE) + +Client for rating.chgk.info API and CSV tables + +[Документация](https://doc.chgk.me/rating-chgk-info/) + +Клиент для REST API сайта рейтинга (rating.chgk.info) и функциональности, которой нет в REST API, но которая доступна через экспорт CSV. +Также содержит REST-сервер для дополнительной функциональности, доступной через CSV. + +Сгенерированные JS-функции для работы с REST API: https://bitbucket.org/gltronred/t-chgk-me/downloads/rating-chgk-info-0.2.1.js + +В следующем большом релизе планируется заменить в части типов для REST API списки значений на множества (Set), например, для составов команд и т.п. Это должно повысить безопасность библиотеки (сложнее будет выстрелить себе в ногу), и не должно ухудшить возможности работы. + +## Установка и запуск + +Для работы с библиотекой необходимо добавить зависимость `rating-chgk-info`. + +Запустить пример можно при помощи `cabal new-run example1`. + +## Пример использования: + +Больше примеров находятся в папке examples + +```haskell +-- Немного наших библиотек +import RatingChgkInfo + +-- И немного стандартных библиотек +import Control.Monad (forM, void) +import Control.Monad.IO.Class (liftIO) +import Data.List (nub) +import Data.Time (LocalTime(..),fromGregorian,midnight) + +-- Точка входа в приложение +main :: IO () + +-- Функция runRatingApi запускает работу клиента, это позволяет разделять эффекты +main = void $ runRatingApi $ do + + -- Получим список всех очных турниров за 2018 год + + let s2018 = LocalTime (fromGregorian 2018 1 1) midnight + e2018 = LocalTime (fromGregorian 2019 1 1) midnight + + -- Функция tournaments получает одну страницу турниров, а функция getAllItems + -- оборачивает подобные функции, чтобы пройтись по всем страницам. + -- Далее из этого списка выбираются очные турниры 2018 года + tourns <- filter (\t -> trs_typeName t == Casual && + trs_dateStart t >= s2018 && + trs_dateEnd t <= e2018) <$> + getAllItems tournaments + + -- Проходимся по полученному списку + ts <- forM tourns $ \TournamentShort{trs_idtournament = ident} -> do + + -- Получаем результаты турнира + res <- tournamentResults ident + + -- Возвращаем названия команд-участниц + pure (map tr_current_name res) + + -- Выводим, сколько уникальных названий было по всем турнирам + liftIO (print (length (nub ts))) + +``` diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/app/extra-rating-api/Main.hs b/app/extra-rating-api/Main.hs new file mode 100644 --- /dev/null +++ b/app/extra-rating-api/Main.hs @@ -0,0 +1,7 @@ +module Main where + +import RatingChgkInfo (extraRatingApiMain) + +main :: IO () +main = extraRatingApiMain + diff --git a/benchmark/Main.hs b/benchmark/Main.hs new file mode 100644 --- /dev/null +++ b/benchmark/Main.hs @@ -0,0 +1,5 @@ +import Gauge.Main + +main :: IO () +main = defaultMain [bench "const" (whnf const ())] + diff --git a/examples/GetAllClaims.hs b/examples/GetAllClaims.hs new file mode 100644 --- /dev/null +++ b/examples/GetAllClaims.hs @@ -0,0 +1,53 @@ + +-- Директива компилятора для использования Text в строковых литералах +{-# LANGUAGE OverloadedStrings #-} + +-- Библиотеки +import RatingChgkInfo +import qualified Data.Text as T +import qualified Data.Text.IO as T + +-- Точка входа +main :: IO () +main = do + -- Получаем список турниров + Right ts <- runRatingApi $ getAllItems tournaments + -- Проходимся по нему + forM_ ts $ \TournamentShort{trs_idtournament = ident} -> do + -- Поскольку здесь запускается отдельный runRatingApi, возможные ошибки + -- одного турнира не приведут к остановке работы для следующих турниров, эти + -- запуски независимы + er <- runRatingApi $ do + -- Выводим идентификатор турнира + liftIO $ print ident + -- Получаем список спорных и выводим их количество + cs <- tournamentControversials ident + liftIO $ T.putStrLn $ T.concat [ "Controversials ok: ", T.pack $ show $ length cs ] + -- Получаем список апелляций и выводим их количество + as <- tournamentAppeals ident + liftIO $ T.putStrLn $ T.concat [ "Appeals ok: ", T.pack $ show $ length as ] + -- Если удалось получить и спорные, и апелляции, выводим OK, иначе FAIL + T.putStrLn $ either (const "FAIL") (const "OK") er + +-- Ещё один пример: получаем новые спорные и апелляции на турнирах с 2016 по 2019 гг. +test2 :: IO () +test2 = void $ runRatingApi $ do + ts <- getAllItems tournaments + let Just s2016 = readMaybe "2016-01-01 00:00:00" + Just jan2019 = readMaybe "2019-01-11 00:00:00" + ss = [ t + | t <- ts + , trs_typeName t `elem` [Synchronous, StrictlySynchronous, Asynchronous] + , trs_dateStart t >= s2016 + , trs_dateEnd t <= jan2019 + ] + forM_ ss $ \TournamentShort{trs_idtournament = ident, trs_dateStart = start} -> do + liftIO $ T.putStr "." + cs <- tournamentControversials ident + as <- tournamentAppeals ident + let ncs = filter ((==ClaimNew) . conStatus) cs + nas = filter ((==ClaimNew) . appStatus) as + when (length ncs + length nas > 0) $ do + liftIO $ T.putStrLn "" + liftIO $ print ((ident, start), (length ncs, length cs), (length nas, length as)) + diff --git a/examples/Simple.hs b/examples/Simple.hs new file mode 100644 --- /dev/null +++ b/examples/Simple.hs @@ -0,0 +1,30 @@ +-- Наша библиотека +import RatingChgkInfo +-- И немного стандартных библиотек +import Control.Monad (forM, void) +import Control.Monad.IO.Class (liftIO) +import Data.List (nub) +import Data.Time (LocalTime(..),fromGregorian,midnight) +-- Точка входа в приложение +main :: IO () +main = void $ runRatingApi $ do + -- Получим список всех очных турниров + -- + -- Функция tournaments получает одну страницу турниров, а функция getAllItems + -- оборачивает подобные функции, чтобы пройтись по всем страницам. + -- Далее из этого списка выбираются очные турниры 2018 года + let s2018 = LocalTime (fromGregorian 2018 1 1) midnight + e2018 = LocalTime (fromGregorian 2019 1 1) midnight + tourns <- filter (\t -> trs_typeName t == Casual && + trs_dateStart t >= s2018 && + trs_dateEnd t <= e2018) <$> + getAllItems tournaments + -- Проходимся по полученному списку + ts <- forM tourns $ \TournamentShort{trs_idtournament = ident} -> do + -- Получаем результаты турнира с идентификатором ident + res <- tournamentResults ident + -- Возвращаем названия команд-участниц + pure (map tr_current_name res) + -- Выводим, сколько уникальных названий было по всем турнирам + liftIO (print (length (nub ts))) + diff --git a/rating-chgk-info.cabal b/rating-chgk-info.cabal new file mode 100644 --- /dev/null +++ b/rating-chgk-info.cabal @@ -0,0 +1,216 @@ +cabal-version: 1.24 +name: rating-chgk-info +version: 0.3.6.3 +synopsis: Client for rating.chgk.info API and CSV tables (documentation in Russian) +description: + Клиент для REST API сайта рейтинга (rating.chgk.info) и функциональности, которой нет в REST API, но которая доступна через экспорт CSV. + Также содержит REST-сервер для дополнительной функциональности, доступной через CSV + . + Документация по типам параметров и возвращаемых значений находится в "RatingChgkInfo.Types" + . + Документация по функциям для работы с REST API находится в "RatingChgkInfo.Api" + . + Документация по функциям для работы с CSV находится в "RatingChgkInfo.NoApi" + . + Примеры работы с библиотекой находятся в папке examples + . + В следующем большом релизе планируется заменить в части типов для REST API списки значений на множества (Set), например, для составов команд и т.п. Это должно повысить безопасность библиотеки, и не должно ухудшить возможности работы. + . + Пример использования: + . + > + > -- Наша библиотека + > import RatingChgkInfo + > -- И немного стандартных библиотек + > import Control.Monad (forM, void) + > import Control.Monad.IO.Class (liftIO) + > import Data.List (nub) + > import Data.Time (LocalTime(..),fromGregorian,midnight) + > -- Точка входа в приложение + > main :: IO () + > main = void $ runRatingApi $ do + > -- Получим список всех очных турниров + > -- + > -- Функция tournaments получает одну страницу турниров, а функция getAllItems + > -- оборачивает подобные функции, чтобы пройтись по всем страницам. + > -- Далее из этого списка выбираются очные турниры 2018 года + > let s2018 = LocalTime (fromGregorian 2018 1 1) midnight + > e2018 = LocalTime (fromGregorian 2019 1 1) midnight + > tourns <- filter (\t -> trs_typeName t == Casual && + > trs_dateStart t >= s2018 && + > trs_dateEnd t <= e2018) <$> + > getAllItems tournaments + > -- Проходимся по полученному списку + > ts <- forM tourns $ \t -> do + > let ident = trs_idtournament t + > -- Получаем результаты турнира + > res <- tournamentResults ident + > -- Возвращаем названия команд-участниц + > pure (map tr_current_name res) + > -- Выводим, сколько уникальных названий было по всем турнирам + > liftIO (print (length (nub ts))) + + +license: BSD3 +license-file: LICENSE +author: Mansur Ziiatdinov +maintainer: gltronred@gmail.com +copyright: 2018-2019 Mansur Ziiatdinov +category: Utility +build-type: Simple +extra-doc-files: README.md + , CHANGELOG.md +tested-with: GHC == 8.4.3 + +library + hs-source-dirs: src + exposed-modules: RatingChgkInfo + RatingChgkInfo.Api + RatingChgkInfo.Extra + RatingChgkInfo.NoApi + RatingChgkInfo.Types + RatingChgkInfo.Types.Unsafe + Prelude + ghc-options: -Wall + -Wincomplete-uni-patterns + -Wincomplete-record-updates + -Wcompat + -Widentities + -Wredundant-constraints + -fhide-source-paths + -Wmissing-export-lists + -Wpartial-fields + 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 + , iconv >=0.4 + , lens >=4.17 + , network >=2.8 + , optparse-generic >=1.3 + , servant >=0.15 + , servant-client >=0.15 + , servant-js >=0.9 + , servant-server >=0.15 + , servant-swagger >=1.1 + , swagger2 >=2.2 + , text >=1.2 + , time >=1.8 + , vector >=0.12 + , wai >=3.2 + , warp >=3.2 + , wreq >=0.5 + default-language: Haskell2010 + + +executable example1 + hs-source-dirs: examples + main-is: Simple.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 + , time + default-language: Haskell2010 + +executable example2 + hs-source-dirs: examples + main-is: GetAllClaims.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 + , text + default-language: Haskell2010 + +executable extra-rating-api + hs-source-dirs: app/extra-rating-api + 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 + default-language: Haskell2010 + + +test-suite rating-chgk-info-test + type: exitcode-stdio-1.0 + hs-source-dirs: test + main-is: Spec.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 + default-language: Haskell2010 + + +benchmark rating-chgk-info-benchmark + type: exitcode-stdio-1.0 + hs-source-dirs: benchmark + 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 + , gauge + , rating-chgk-info + , relude + default-language: Haskell2010 + + diff --git a/src/Prelude.hs b/src/Prelude.hs new file mode 100644 --- /dev/null +++ b/src/Prelude.hs @@ -0,0 +1,8 @@ +-- | Uses [relude](https://hackage.haskell.org/package/relude) as default Prelude. + +module Prelude + ( module Relude + ) where + +import Relude + diff --git a/src/RatingChgkInfo.hs b/src/RatingChgkInfo.hs new file mode 100644 --- /dev/null +++ b/src/RatingChgkInfo.hs @@ -0,0 +1,333 @@ +{-| +Module : RatingChgkInfo +Description : Функции для работы с API сайта рейтинга +Copyright : (c) Mansur Ziiatdinov, 2018-2019 +License : BSD-3 +Maintainer : chgk@pm.me +Stability : experimental +Portability : POSIX + + +Клиент для REST API сайта рейтинга (rating.chgk.info) и функциональности, которой нет в REST API, но которая доступна через экспорт CSV. +Также содержит REST-сервер для дополнительной функциональности, доступной через CSV + +Документация по типам параметров и возвращаемых значений находится в "RatingChgkInfo.Types" + +Документация по функциям для работы с REST API находится в "RatingChgkInfo.Api" + +Документация по функциям для работы с CSV находится в "RatingChgkInfo.NoApi" + +В следующем большом релизе планируется заменить в части типов для REST API списки значений на множества (Set), например, для составов команд и т.п. Это должно повысить безопасность библиотеки, и не должно ухудшить возможности работы. + +Пример использования: + +> +> -- Немного наших библиотек +> import RatingChgkInfo.Types +> import RatingChgkInfo.Api +> +> -- И немного стандартных библиотек +> import Control.Monad (forM, void) +> import Control.Monad.IO.Class (liftIO) +> import Data.List (nub) +> import Data.Time (LocalTime(..),fromGregorian,midnight) +> +> -- Точка входа в приложение +> main :: IO () +> +> -- Функция runRatingApi запускает работу клиента, это позволяет разделять эффекты +> main = void $ runRatingApi $ do +> +> -- Получим список всех очных турниров за 2018 год +> +> let s2018 = LocalTime (fromGregorian 2018 1 1) midnight +> e2018 = LocalTime (fromGregorian 2019 1 1) midnight +> +> -- Функция tournaments получает одну страницу турниров, а функция getAllItems +> -- оборачивает подобные функции, чтобы пройтись по всем страницам. +> -- Далее из этого списка выбираются очные турниры 2018 года +> tourns <- filter (\t -> trs_typeName t == Casual && +> trs_dateStart t >= s2018 && +> trs_dateEnd t <= e2018) <$> +> getAllItems tournaments +> +> -- Проходимся по полученному списку +> ts <- forM tourns $ \t -> do +> +> -- API сайта рейтинга выдаёт строки в качестве идентификаторов, а нам нужны числа +> let ident = apiIdToInt (trs_idtournament t) +> +> -- Получаем результаты турнира +> res <- tournamentResults ident +> +> -- Возвращаем названия команд-участниц +> pure (map tr_current_name res) +> +> -- Выводим, сколько уникальных названий было по всем турнирам +> liftIO (print (length (nub ts))) +-} + +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TypeOperators #-} + +{- + +Imports selected entities from rating.chgk.info into following directory structure: + ++ players/ +| + NNxxx/ +| + NNABC.json +| + NNABC.M.json +| + NNABC.diff.M.json ++ tournaments/ +| + NNxxx/ +| + NNABC/ +| + props.json -> props.M.json +| + props.M.json +| + props.diff.M.json +| + recap.json -> recap.M.json +| + recap.M.json +| + recap.diff.M.json +| + result.json -> result.M.json +| + result.M.json +| + result.diff.M.json +| + request.json -> request.M.json +| + request.M.json +| + request.diff.M.json +| + controversial.json -> controversial.M.json +| + controversial.M.json +| + controversial.diff.M.json +| + appeal.json -> appeal.M.json +| + appeal.M.json +| + appeal.diff.M.json ++ lastsync + +Here NNABC is numeric identifier, M is a timestamp (seconds from epoch) of synchronization start. +File entity.diff.M.json describes changes between M version and next version. +File lastsync contains a timestamp of last synchronization attempt. +-} + +module RatingChgkInfo + ( -- * Библиотека API + module Rating + , generateJavascript + -- * Сервер дополнительного API + , extraRatingApiDesc + , extraRatingApiApp + , extraRatingApiMain + ) where + +-- import RatingChgkInfo.Api (getAllItems, runRatingApi) +import RatingChgkInfo.Api as Rating +import RatingChgkInfo.Extra +import RatingChgkInfo.NoApi as Rating +import RatingChgkInfo.Types as Rating + +import qualified Control.Exception as E +import Data.Aeson (encode) +-- import Options.Generic +-- import Data.Aeson.Diff +import qualified Data.ByteString.Lazy.Char8 as LB +import Data.Text (Text) +-- import qualified Data.Text as T +-- import qualified Data.Text.IO as T +-- import Data.Time (getCurrentTime, diffUTCTime, fromGregorian, UTCTime(..)) +import Network.Socket +import Network.Wai.Handler.Warp +-- import Options.Generic (unwrapRecord, Unwrapped) +import Servant.JS +-- import System.Directory +import System.Environment +-- import System.FilePath +-- import Text.Printf +-- import Text.Read + +-- -- | Тип для работы утилиты командной строки +-- data CliOptions w +-- = Players +-- { _diff :: w ::: Bool "Generate diff if entity exists" +-- } +-- | Tournaments +-- { _diff :: w ::: Bool "Generate diff if entity exists" +-- } +-- | Recaps +-- { _tournament :: w ::: Int "Tournament identifier" +-- , _diff :: w ::: Bool "Generate diff if entity exists" +-- } +-- | Results +-- { _tournament :: w ::: Int "Tournament identifier" +-- , _diff :: w ::: Bool "Generate diff if entity exists" +-- } +-- | Requests +-- { _tournament :: w ::: Int "Tournament identifier" +-- , _withTeams :: w ::: Bool "Include teams" +-- , _diff :: w ::: Bool "Generate diff if entity exists" +-- } +-- | Controversials +-- { _tournament :: w ::: Int "Tournament identifier" +-- , _diff :: w ::: Bool "Generate diff if entity exists" +-- } +-- | Appeals +-- { _tournament :: w ::: Int "Tournament identifier" +-- , _diff :: w ::: Bool "Generate diff if entity exists" +-- } +-- | GenerateJs +-- deriving (Generic) +-- +-- instance ParseRecord (CliOptions Wrapped) where +-- parseRecord = parseRecordWithModifiers $ lispCaseModifiers +-- deriving instance Show (CliOptions Unwrapped) +-- +-- log, logLn :: LByteString -> IO () +-- log = LB.hPutStr stderr +-- logLn = LB.hPutStrLn stderr +-- +-- createDirs :: IO () +-- createDirs = do +-- createDirectoryIfMissing True "players" +-- createDirectoryIfMissing True "tournaments" +-- +-- printDot :: Int -> Int -> IO () +-- printDot cnt ident = do +-- when (ident `mod` cnt == 0) $ log "." +-- when (ident `mod` (10*cnt) == 0) $ log " " +-- when (ident `mod` (80*cnt) == 0) $ logLn "" +-- +-- getPlayers :: Bool -> Int -> IO () +-- getPlayers _diff ts = do +-- logLn "Rating Api: GET /players" +-- eps <- runRatingApi $ getAllItems $ \mpage -> do +-- liftIO $ printDot 1 $ fromMaybe 1 mpage +-- Api.players mpage +-- logLn "" +-- case eps of +-- Left err -> print err +-- Right ps -> withCurrentDirectory "players" $ do +-- logLn "Write players:" +-- forM_ ps $ \p -> do +-- let ident = apiIdToInt $ idplayer p +-- dir = (printf "%03d" $ ident `div` 1000) ++ "xxx" +-- fname = show ident ++ "." ++ show ts ++ ".json" +-- -- lfile = show ident ++ "." ++ ".json" +-- printDot 1000 ident +-- createDirectoryIfMissing True dir +-- LB.writeFile (dir fname) $ encode p +-- logLn "" +-- +-- getTournaments :: Bool -> Int -> IO () +-- getTournaments _diff now = do +-- logLn "Rating Api: GET /tournaments" +-- eps <- runRatingApi $ getAllItems $ \mpage -> do +-- liftIO $ printDot 1 $ fromMaybe 1 mpage +-- Api.tournaments mpage +-- logLn "" +-- case eps of +-- Left err -> print err +-- Right ts -> withCurrentDirectory "tournaments" $ do +-- logLn "Write tournaments:" +-- forM_ (zip [1..] ts) $ \(i,tourn) -> do +-- let t = apiIdToInt $ trs_idtournament tourn +-- dname = printf "%02d" (t `div` 1000) ++ "xxx" +-- fname = "props." ++ show now ++ ".json" +-- shortName = "short." ++ show now ++ ".json" +-- dir = dname show t +-- printDot 10 i +-- createDirectoryIfMissing True dir +-- et <- runRatingApi $ Api.tournament t +-- LB.writeFile (dir shortName) $ encode tourn +-- case et of +-- Left err -> print err +-- Right [fullTourn] -> LB.writeFile (dir fname) $ encode fullTourn +-- Right _ -> error "Tournament API has changed, it doesn't return [tourn]" +-- +-- getRecaps :: Int -> IO () +-- getRecaps _t = pure () +-- +-- getResults :: Int -> IO () +-- getResults _t = pure () +-- +-- getRequests :: Int -> Int -> IO () +-- getRequests t now = do +-- let dname = printf "%02d" (t `div` 1000) ++ "xxx" +-- fname = "request." ++ show now ++ ".json" +-- dir = "tournaments" dname show t +-- createDirectoryIfMissing True dir +-- withCurrentDirectory dir $ do +-- logLn $ LB.pack $ "Rating Non-API: team_synch_data " ++ show t +-- ers <- NoApi.requests t +-- case ers of +-- Left err -> print err +-- Right rs -> LB.writeFile fname $ encode rs +-- logLn "" +-- +-- getControversials :: Int -> IO () +-- getControversials _t = pure () +-- +-- getAppeals :: Int -> IO () +-- getAppeals _t = pure () +-- +-- importer :: CliOptions Unwrapped -> IO () +-- importer opts = do +-- print (opts :: CliOptions Unwrapped) +-- -- get current timestamp +-- old <- ifM (doesFileExist "lastsync") (read <$> readFile "lastsync") (pure 0) +-- let toEpoch :: UTCTime -> Double +-- toEpoch = realToFrac . flip diffUTCTime (UTCTime (fromGregorian 1970 1 1) 0) +-- now <- (truncate . toEpoch) <$> getCurrentTime +-- print (old :: Int,now :: Int) +-- -- create directories +-- createDirs +-- -- actual parsing +-- case opts of +-- Players diff -> getPlayers diff now +-- Tournaments diff -> getTournaments diff now +-- Recaps t _diff -> getRecaps t +-- Results t _diff -> getResults t +-- Requests t _withTeams _diff -> getRequests t now +-- Controversials t _diff -> getControversials t +-- Appeals t _diff -> getAppeals t +-- writeFile "lastsync" $ show now +-- + +-- | Текст js-скрипта +generateJavascript :: Text +generateJavascript = jsForAPI (Proxy :: Proxy RatingApi) vanillaJS + +-- ratingChgkInfoApp :: IO () +-- ratingChgkInfoApp = do +-- -- get cli options +-- opts <- unwrapRecord help +-- case opts of +-- GenerateJs -> T.putStrLn $ jsForAPI (Proxy :: Proxy RatingApi) vanillaJS +-- _ -> importer opts +-- where +-- help = T.intercalate "\n" +-- [ "Import rating.chgk.info entities" +-- , "" +-- , "Not implemented commands: controversials, appeals" +-- , "Implemented partially: " +-- , " - tournaments parse only fields from API" +-- , " - requests do not parse narrator and can contain zero ids (r.c.i. limitation)" +-- , "Differences from API:" +-- , " - ids are converted to Int" +-- ] + +-- | Запуск сервера дополнительного API +extraRatingApiMain :: IO () +extraRatingApiMain = do + args <- getArgs + case args of + ["doc"] -> LB.putStrLn $ encode extraRatingApiDesc + ["srv", addr] -> case readMaybe addr of + Just port -> run port extraRatingApiApp + Nothing -> E.bracket + (socket AF_UNIX Stream 0 >>= \s -> bind s (SockAddrUnix addr) >> pure s) + close + (\sock -> runSettingsSocket defaultSettings sock extraRatingApiApp) + _ -> usage + where usage = putStrLn "Usage: extra-rating-api [doc | srv | srv ]" + diff --git a/src/RatingChgkInfo/Api.hs b/src/RatingChgkInfo/Api.hs new file mode 100644 --- /dev/null +++ b/src/RatingChgkInfo/Api.hs @@ -0,0 +1,282 @@ +{-| +Module : RatingChgkInfo.Api +Description : Функции для работы с API сайта рейтинга +Copyright : (c) Mansur Ziiatdinov, 2018-2019 +License : BSD-3 +Maintainer : chgk@pm.me +Stability : experimental +Portability : POSIX + +Функции здесь повторяют те запросы, которые доступны в API сайта рейтинга. Те +функции, которые недоступны через API, реализованы в 'RatingChgkInfo.NoApi'. + +Кроме того, есть вспомогательная функция 'getAllItems' для удобства. +-} +module RatingChgkInfo.Api + ( -- * Работа с API + RatingClient + , runRatingApi + -- * Информация об игроках + , 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 + , tournamentTeamResult + -- ** Составы на турнире + , tournamentRecap + -- ** Спорные и апелляции + , tournamentControversials + , tournamentAppeals + -- * Различные способы поиска + -- + -- $maybeParams + , teamSearch + , playerSearch + -- * Вспомогательные функции + , getAllItems + ) where + +import RatingChgkInfo.Types + +import Network.HTTP.Client (newManager,defaultManagerSettings) +import Servant.API +import Servant.Client + +api :: Proxy RatingApi +api = Proxy + +-- | Список всех игроков +players :: Maybe Int -- ^ Номер страницы в результате + -> RatingClient (Items Player) -- ^ Список игроков, по 1000 элементов + +-- | Информация об игроке +-- +-- __API NOTE__. Результат должен быть 'Player', а не список игроков из одного элемента +player :: PlayerId -- ^ Идентификатор игрока + -> RatingClient [Player] -- ^ Информация об игроке, список из единственного элемента + +-- | Команды, в базовых составах которых играл игрок +playerTeams :: PlayerId -- ^ Идентификатор игрока + -> RatingClient [PlayerTeam] -- ^ Список команд игрока + +-- | Команды, в базовый состав которых игрок входит в текущем сезоне +playerLastTeam :: PlayerId -- ^ Идентификатор игрока + -> RatingClient [PlayerTeam] -- ^ Список команд игрока + +-- | Команды, в базовый состав которых игрок входил в указанном сезоне +playerTeam :: PlayerId -- ^ Идентификатор игрока + -> Int -- ^ Идентификатор сезона + -> RatingClient [PlayerTeam] -- ^ Список команд игрока + +-- | Турниры, которые отыграл игрок, по сезонам +playerTournaments :: PlayerId -- ^ Идентификатор игрока + -> RatingClient (SeasonMap PlayerSeason) -- ^ Турниры игрока по сезонам + +-- | Турниры, которые игрок отыграл в текущем сезоне +playerLastTournament :: PlayerId -- ^ Идентификатор игрока + -> RatingClient PlayerSeason + +-- | Турниры, которые игрок отыграл в указанном сезоне +playerTournament :: PlayerId -- ^ Идентификатор игрока + -> Int -- ^ Идентификатор сезона + -> RatingClient PlayerSeason + +-- | Рейтинги игрока +playerRatings :: PlayerId -- ^ Идентификатор игрока + -> RatingClient [PlayerRating] -- ^ Список рейтингов игрока, порядок не определён + +-- | Рейтинг игрока в последнем релизе +-- +-- __API NOTE__. Работает не всегда: например, для 54345 в декабре 2018 ничего не возвращало (off-by-one error?) +playerLastRating :: PlayerId -- ^ Идентификатор игрока + -> RatingClient PlayerRating + +-- | Рейтинг игрока в указанном релизе +playerRating :: PlayerId -- ^ Идентификатор игрока + -> Int -- ^ Идентификатор релиза + -> RatingClient PlayerRating + +-- | Список всех команд +teams :: Maybe Int -- ^ Номер страницы в результате + -> RatingClient (Items Team) -- ^ Команды по 1000 элементов + +-- | Информация о команде +-- +-- __API NOTE__: должна быть команда, а не список из команд +team :: TeamId -- ^ Идентификатор команды + -> RatingClient [Team] -- ^ Команда, список из единственного элемента + +-- | Базовые составы команды +teamBaseRecaps :: TeamId -- ^ Идентификатор команды + -> RatingClient (SeasonMap TeamBaseRecap) -- ^ Базовые составы по сезонам + +-- | Базовый состав команды в последнем сезоне +teamLastBaseRecap :: TeamId -- ^ Идентификатор команды + -> RatingClient TeamBaseRecap + +-- | Базовый состав команды в указанном сезоне +teamBaseRecap :: TeamId -- ^ Идентификатор команды + -> Int -- ^ Идентификатор сезона + -> RatingClient TeamBaseRecap + +-- | Турниры, отыгранные командой +teamTournaments :: TeamId -- ^ Идентификатор команды + -> RatingClient (SeasonMap TeamTournament) -- ^ Турниры команды по сезонам + +-- | Турниры, отыгранные командой в последнем сезоне +teamLastTournament :: TeamId -- ^ Идентификатор команды + -> RatingClient TeamTournament + +-- | Турниры, отыгранные командой в указанном сезоне +teamTournament :: TeamId -- ^ Идентификатор команды + -> Int -- ^ Идентификатор сезона + -> RatingClient TeamTournament + +-- | Рейтинги команды +teamRatings :: TeamId -- ^ Идентификатор команды + -> RatingClient [TeamRating] -- ^ Список рейтингов команды, порядок не определён + +-- | Последний рейтинг команды по формуле A +-- +-- __API NOTE__. Работает не всегда: для 1 ничего не возвращает (off-by-one error?) +teamRatingA :: TeamId -- ^ Идентификатор команды + -> RatingClient TeamRating + +-- | Последний рейтинг команды по формуле B +-- +-- __API NOTE__. Работает не всегда: для 1 ничего не возвращает (off-by-one error?) +teamRatingB :: TeamId -- ^ Идентификатор команды + -> RatingClient TeamRating + +-- | Рейтинг команды в указанном релизе +teamRating :: TeamId -- ^ Идентификатор команды + -> Int -- ^ Идентификатор релиза + -> RatingClient TeamRating + +-- | Список всех турниров +tournaments :: Maybe Int -- ^ Номер страницы в результате + -> RatingClient (Items TournamentShort) -- ^ Информация о турнирах по 1000 элементов + +-- | Информация о турнире +-- +-- __API NOTE__: должен быть турнир, а не список турниров +tournament :: TournamentId -- ^ Идентификатор турнира + -> RatingClient [Tournament] -- ^ Единственный элемент списка - турнир + +-- | Результаты турнира +tournamentResults :: TournamentId -- ^ Идентификатор турнира + -> RatingClient [TournamentResult] -- ^ Результаты по командам, порядок не определён + +-- | Результаты турнира для команд города +tournamentResultsTown :: TournamentId -- ^ Идентификатор турнира + -> Int -- ^ Идентификатор города + -> RatingClient [TournamentResult] -- ^ Результаты по командам, порядок не определён + +-- | Результаты турнира для команд региона +tournamentResultsRegion :: TournamentId -- ^ Идентификатор турнира + -> Int -- ^ Идентификатор региона + -> RatingClient [TournamentResult] -- ^ Результаты по командам, порядок не определён + +-- | Результаты турнира для команд страны +tournamentResultsCountry :: TournamentId -- ^ Идентификатор турнира + -> Int -- ^ Идентификатор страны + -> RatingClient [TournamentResult] -- ^ Результаты по командам, порядок не определён + +-- | Составы указанной команды на турнире +tournamentRecap :: TournamentId -- ^ Идентификатор турнира + -> TeamId -- ^ Идентификатор команды + -> RatingClient [RecapPlayer] -- ^ Список игроков с флагами К\/Б\/Л + +-- | Результат указанной команды на турнире +tournamentTeamResult :: TournamentId -- ^ Идентификатор турнира + -> TeamId -- ^ Идентификатор команды + -> RatingClient [TourResult] -- ^ Список результатов по турам + +-- | Спорные на турнире +tournamentControversials :: TournamentId -- ^ Идентификатор турнира + -> RatingClient [Controversial] -- ^ Спорные + +-- | Апелляции на турнире +tournamentAppeals :: TournamentId -- ^ Идентификатор турнира + -> RatingClient [Appeal] -- ^ Апелляции + +-- $maybeParams +-- +-- В функции поиска передаётся несколько значений типа 'Maybe a'. Если +-- соответствующее значение установлено, по этому параметру производится поиск. +-- Если установлено несколько значений, они объединяются при помощи логической +-- связки И. + +-- | Поиск по командам +teamSearch :: Maybe Text -- ^ Название (name) + -> Maybe Text -- ^ Город (town) + -> Maybe Text -- ^ Регион (region_name) + -> Maybe Text -- ^ Страна (country_name) + -> Bool -- ^ Играла в текущем сезоне (active_this_season) + -> Maybe Int -- ^ Номер страницы в результате + -> RatingClient (Items Team) -- ^ Список команд по 1000 элементов + +-- | Поиск по игрокам +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 + +-- | Получение всех элементов из запроса с разбиением по страницам +-- +-- В функции предполагается, что сайт рейтинга, как и указано в документации, +-- разбивает ответ на куски по 1000 элементов +getAllItems :: (Maybe Int -> RatingClient (Items a)) -- ^ Запрос с разбиением на страницы + -> RatingClient [a] -- ^ Список всех элементов +getAllItems getter = do + Items cnt is0 <- getter Nothing + let lastPage = ceiling (fromIntegral cnt / 1000 :: Double) + iss <- forM [2..lastPage] $ fmap items . getter . Just + pure $ concat $ is0:iss + +-- | Запуск клиента API сайта рейтинга +-- +-- Все запросы внутри 'RatingClient' используют один и тот же менеджер соединений +runRatingApi :: RatingClient a -- ^ Набор команд, работающих с API сайта рейтинга + -> IO (Either ServantError a) -- ^ Результат работы, либо ошибка +runRatingApi act = do + mgr <- newManager defaultManagerSettings + runClientM act $ mkClientEnv mgr $ BaseUrl Http "rating.chgk.info" 80 "api" + diff --git a/src/RatingChgkInfo/Extra.hs b/src/RatingChgkInfo/Extra.hs new file mode 100644 --- /dev/null +++ b/src/RatingChgkInfo/Extra.hs @@ -0,0 +1,66 @@ +{-| +Module : RatingChgkInfo.Extra +Description : Сервер дополнительного API сайта рейтинга (доступного через CSV) +Copyright : (c) Mansur Ziiatdinov, 2018-2019 +License : BSD-3 +Maintainer : chgk@pm.me +Stability : experimental +Portability : POSIX + +Сервер работает по адресу https://extra.chgk.me, там же доступна спецификация API +-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeOperators #-} + +module RatingChgkInfo.Extra + ( ExtraRatingApi + , extraRatingApiDesc + , extraRatingApiApp + ) where + +import qualified RatingChgkInfo.NoApi as NoApi +import RatingChgkInfo.Types (Request, TournamentId) + +import Control.Lens +import qualified Data.ByteString.Lazy as LBS +import Data.Swagger +import Network.Wai (Application) +import Servant +import Servant.Swagger + +-- | Описание API. Пока доступен единственный запрос на получение списка +-- площадок турнира +type ExtraRatingApi + = "requests" :> Capture "tournament-id" TournamentId :> Get '[JSON] [Request] + +-- | Генерируемое из кода описание в формате Swagger +extraRatingApiDesc :: Swagger +extraRatingApiDesc = toSwagger (Proxy :: Proxy ExtraRatingApi) + & info.title .~ "Дополнительный API для сайта рейтинга" + & info.version .~ "0.2" + & info.description ?~ "Вспомогательные функции API для работы с сайтом рейтинга." + & info.license ?~ "MIT" + & info.contact ?~ (mempty + & name ?~ "Мансур Зиятдинов" + & email ?~ "chgk@pm.me" + ) + & host ?~ "extra.chgk.me" + & basePath ?~ "/api/v0.2.1" + +-- | Приложение, которое запускает сервер API +extraRatingApiApp :: Application +extraRatingApiApp = serve (Proxy :: Proxy ExtraRatingApi) requests + where requests :: TournamentId -> Handler [Request] + requests tid = do + ers <- liftIO $ NoApi.requests tid + case ers of + Left "No such tournament, returned html" -> + throwError $ err404 { errBody = "Probably, no such tournament, rating.chgk.info returns html" } + Left "Not a synch, or no requests yet" -> + throwError $ err404 { errBody = "Not a synch, or no requests found" } + Left err -> + throwError $ err500 { errBody = LBS.fromStrict err } + Right rs -> + pure rs + diff --git a/src/RatingChgkInfo/NoApi.hs b/src/RatingChgkInfo/NoApi.hs new file mode 100644 --- /dev/null +++ b/src/RatingChgkInfo/NoApi.hs @@ -0,0 +1,194 @@ +{-| +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 ';' + } + diff --git a/src/RatingChgkInfo/Types.hs b/src/RatingChgkInfo/Types.hs new file mode 100644 --- /dev/null +++ b/src/RatingChgkInfo/Types.hs @@ -0,0 +1,625 @@ +{-| +Module : RatingChgkInfo.Types +Description : Типы для библиотеки работы с API сайта рейтинга +Copyright : (c) Mansur Ziiatdinov, 2018-2019 +License : BSD-3 +Maintainer : chgk@pm.me +Stability : experimental +Portability : POSIX + +Типы в этом модуле практически совпадают с теми, которые возвращаются сайтом +рейтинга. Поэтому и проблемы у них (такие, как использование строк вместо целых +и т.п.) общие. Часть этих проблем задокументирована при помощи пометок __API NOTE__. + +Возможно, в следующих версиях библиотеки будут какие-то способы обезопасить себя +от ошибок, либо (надеюсь) в результате развития API сайта рейтинга, либо без +этого. +-} + +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE OverloadedLists #-} +{-# LANGUAGE StrictData #-} +{-# LANGUAGE TypeOperators #-} + +module RatingChgkInfo.Types + ( -- * Работа с API + -- + -- | В этом разделе описаны типы, используемые при запросах к + -- предоставляемому сайтом рейтинга REST API + -- + RatingClient + -- ** Общие типы + , Items(..) + , SeasonMap(..) + , RatingApi + -- ** Игрок + , Player(..) + , PlayerTeam(..) + , PlayerSeason(..) + , PlayerTournament(..) + , PlayerRating(..) + -- ** Команда + , Team(..) + , TeamBaseRecap(..) + , TeamTournament(..) + , TeamRating(..) + -- ** Турнир + , TournamentShort(..) + , Tournament(..) + , tournamentToShort + , TournamentResult(..) + , RecapPlayer(..) + , TourResult(..) + , Controversial (..) + , Appeal (..) + -- ** Типы-перечисления + , RatingFormula(..) + , TournamentType(..) + , ClaimStatus (..) + , AppealType (..) + -- ** Типы для идентификаторов + -- + -- | Экспортируются без функций, позволяющих вытащить данные из типа, + -- поскольку предполагается, что идентификаторы получаются только из + -- запросов к серверу. Это должно помочь избежать ошибок, когда + -- идентификатор одного типа (например, id игрока) ошибочно передаётся туда, + -- где ожидается идентификатор другого типа (например, id турнира). Если вам + -- совершенно точно без этого не обойтись, используйте модуль + -- "RatingChgkInfo.Types.Unsafe". + , PlayerId + , TeamId + , TournamentId + -- + -- * Работа без API + -- + -- | В этом разделе - типы, которые используются при запросах к CSV-таблицам + -- на сайте рейтинга для функциональности, которая (надеюсь, пока) __не__ + -- предоставляется через REST API + -- + -- Функции для работы с этими типами находятся в модуле "RatingChgkInfo.NoApi" + -- + , Request(..) + , TeamName(..) + ) where + +import RatingChgkInfo.Types.Unsafe + +import Control.Lens hiding (Wrapped, Unwrapped) +import Data.Aeson +import Data.List (lookup) +import Data.Map (Map) +import qualified Data.Map as M +import Data.Swagger (SchemaOptions, declareNamedSchema, genericDeclareNamedSchema, schema, title, description, ToSchema) +import qualified Data.Swagger as Swagger +import qualified Data.Text as T +import Data.Time +import Servant.API +import Servant.Client (ClientM) +import Text.Read (read) + +-------------------------------------------------------------------------------- +-- API Types + +-- | Синоним типа для реэкспорта. Монада, в которой возможно выполнять запросы к REST API сайта рейтинга +type RatingClient = ClientM + +-- | Список элементов с общим количеством для разбиения на страницы +data Items a = Items + { total :: Int -- ^ Общее количество + , items :: [a] -- ^ Сами элементы + } deriving (Eq,Show,Read,Generic) + +instance FromJSON a => FromJSON (Items a) where + parseJSON = withObject "Items list" $ \v -> + Items <$> (read <$> v .: "total_items") <*> v .: "items" + +-- | Отображение сезонов на элементы +-- +-- __API NOTE__: пустое отображение должно обозначаться @{}@ вместо @[]@ +newtype SeasonMap a = SeasonMap { unSeasonMap :: Map Int a } deriving (Eq,Show,Read,Generic) + +instance FromJSON a => FromJSON (SeasonMap a) where + parseJSON (Array []) = pure $ SeasonMap M.empty + parseJSON v = SeasonMap <$> parseJSON v + +-- | Игрок +data Player = Player + { idplayer :: PlayerId -- ^ Идентификатор игрока. __API NOTE__: должен быть @Int@ + , surname :: Text -- ^ Фамилия игрока + , name :: Text -- ^ Имя игрока (пустое, если нет имени) + , patronymic :: Text -- ^ Отчество игрока (пустое, если его нет) + , db_chgk_info_tag :: Maybe Text -- ^ Логин в Базе вопросов. Не возвращается в общем списке игроков, только при запросе отдельного игрока + } deriving (Eq,Show,Read,Generic) + +instance FromJSON Player +instance ToJSON Player + +-- | Игрок в базовом составе команды +data PlayerTeam = PlayerTeam + { pt_idplayer :: PlayerId -- ^ Идентификатор игрока. __API NOTE__: должен быть @Int@ + , pt_idteam :: TeamId -- ^ Идентификатор команды. __API NOTE__: должен быть @Int@ + , pt_idseason :: Text -- ^ Идентификатор сезона. __API NOTE__: должен быть @Int@ + , pt_is_captain :: Text -- ^ Является ли игрок капитаном (0/1). __API NOTE__: должен быть @Bool@ + , pt_added_since :: Day -- ^ С какого момента игрок в базовом составе + } deriving (Eq,Show,Read,Generic) + +instance FromJSON PlayerTeam where + parseJSON = genericParseJSON $ jsonOpts '_' 3 +instance ToJSON PlayerTeam where + toJSON = genericToJSON $ jsonOpts '_' 3 + toEncoding = genericToEncoding $ jsonOpts '_' 3 + +-- | Турниры, сыгранные игроком в сезоне +data PlayerSeason = PlayerSeason + { ps_idplayer :: PlayerId -- ^ Идентификатор игрока. __API NOTE__: должен быть @Int@ + , ps_idseason :: Text -- ^ Идентификатор сезона. __API NOTE__: должен быть @Int@ + , ps_tournaments :: [PlayerTournament] -- ^ Список турниров, сыгранных игроком в этом сезоне + } deriving (Eq,Show,Read,Generic) + +instance FromJSON PlayerSeason where + parseJSON = genericParseJSON $ jsonOpts '_' 3 +instance ToJSON PlayerSeason where + toJSON = genericToJSON $ jsonOpts '_' 3 + toEncoding = genericToEncoding $ jsonOpts '_' 3 + +-- | Турнир, сыгранный игроком +data PlayerTournament = PlayerTournament + { ptr_idtournament :: TournamentId -- ^ Идентификатор турнира. __API NOTE__: должен быть @Int@ + , ptr_idteam :: TeamId -- ^ Идентификатор команды. __API NOTE__: должен быть @Int@ + , ptr_in_base_team :: Text -- ^ Игра за базовую команды (0/1). __API NOTE__: должен быть @Bool@ + } deriving (Eq,Show,Read,Generic) + +instance FromJSON PlayerTournament where + parseJSON = genericParseJSON $ jsonOpts '_' 4 +instance ToJSON PlayerTournament where + toJSON = genericToJSON $ jsonOpts '_' 4 + toEncoding = genericToEncoding $ jsonOpts '_' 4 + +-- | Рейтинг игрока +data PlayerRating = PlayerRating + { prat_idplayer :: PlayerId -- ^ Идентификатор игрока. __API NOTE__: должен быть Int + , prat_idrelease :: Text -- ^ Идентификатор релиза. __API NOTE__: должен быть Int + , prat_rating :: Text -- ^ Рейтинг. __API NOTE__: должен быть Int + , prat_rating_position :: Text -- ^ Позиция в рейтинге. __API NOTE__: должен быть Int или Rational + , prat_date :: Day -- ^ Дата, когда был рассчитан рейтинг + , prat_tournaments_in_year :: Text -- ^ Количество сыгранных турниров за год. __API NOTE__: должен быть Int + , prat_tournament_count_total :: Text -- ^ Количество сыгранных турниров всего. __API NOTE__: должен быть Int + } deriving (Eq,Show,Read,Generic) + +instance FromJSON PlayerRating where + parseJSON = genericParseJSON $ jsonOpts '_' 5 +instance ToJSON PlayerRating where + toJSON = genericToJSON $ jsonOpts '_' 5 + toEncoding = genericToEncoding $ jsonOpts '_' 5 + +-- | Команда +data Team = Team + { tm_idteam :: TeamId -- ^ Идентификатор команды. __API NOTE__: должен быть Int + , tm_name :: Text -- ^ Название команды + , tm_town :: Text -- ^ Город приписки команды + , tm_region_name :: Text -- ^ Регион приписки + , tm_country_name :: Text -- ^ Страна + , tm_tournaments_this_season :: Text -- ^ Количество турниров, сыгранных в последнем сезоне. __API NOTE__: должен быть Int + , tm_tournaments_total :: Text -- ^ Количество турниров всего. __API NOTE__: должен быть Int + , tm_comment :: Maybe Text -- ^ Вероятно, комментарий + } deriving (Eq,Show,Read,Generic) + +instance FromJSON Team where + parseJSON = genericParseJSON $ jsonOpts '_' 3 +instance ToJSON Team where + toJSON = genericToJSON $ jsonOpts '_' 3 + toEncoding = genericToEncoding $ jsonOpts '_' 3 + +-- | Базовый состав команды +data TeamBaseRecap = TeamBaseRecap + { tbr_idteam :: TeamId -- ^ Идентификатор команды. __API NOTE__: должен быть Int + , tbr_idseason :: Text -- ^ Идентификатор сезона. __API NOTE__: должен быть Int + , tbr_players :: [Text] -- ^ Список игроков (вместе с капитаном). TODO: должен быть Set Int + , tbr_captain :: Text -- ^ Капитан команды. __API NOTE__: должен быть Maybe Int + } deriving (Eq,Show,Read,Generic) + +instance FromJSON TeamBaseRecap where + parseJSON = genericParseJSON $ jsonOpts '_' 4 +instance ToJSON TeamBaseRecap where + toJSON = genericToJSON $ jsonOpts '_' 4 + toEncoding = genericToEncoding $ jsonOpts '_' 4 + +-- | Турниры, сыгранные командой в сезоне +data TeamTournament = TeamTournament + { tt_idteam :: TeamId -- ^ Идентификатор команды. __API NOTE__: должен быть Int + , tt_idseason :: Text -- ^ Идентификатор сезона. __API NOTE__: должен быть Int + , tt_tournaments :: [Text] -- ^ Список идентификаторов турниров. TODO: должен быть Set Int + } deriving (Eq,Show,Read,Generic) + +instance FromJSON TeamTournament where + parseJSON = genericParseJSON $ jsonOpts '_' 3 +instance ToJSON TeamTournament where + toJSON = genericToJSON $ jsonOpts '_' 3 + toEncoding = genericToEncoding $ jsonOpts '_' 3 + +-- | Формула рейтинга +data RatingFormula + = FormulaA -- ^ Рейтинг А (аддитивный) + | FormulaB -- ^ Рейтинг Б (балансный) + deriving (Eq,Show,Read,Generic) + +instance FromJSON RatingFormula where + parseJSON = withText "Formula should be String" $ \case + "a" -> pure FormulaA + "b" -> pure FormulaB + _ -> fail "Only two formula: a & b" +instance ToJSON RatingFormula where + toJSON FormulaA = toJSON ("a" :: Text) + toJSON FormulaB = toJSON ("b" :: Text) + toEncoding FormulaA = toEncoding ("a" :: Text) + toEncoding FormulaB = toEncoding ("b" :: Text) + +-- | Рейтинг команды +data TeamRating = TeamRating + { rat_idteam :: TeamId -- ^ Идентификатор команды. __API NOTE__: должен быть Int + , rat_idrelease :: Text -- ^ Идентификатор релиза. __API NOTE__: должен быть Int + , rat_rating :: Text -- ^ Рейтинг команды. __API NOTE__: должен быть Int + , rat_rating_position :: Text -- ^ Позиция в рейтинге. __API NOTE__: должен быть Int или Rational + , rat_date :: Text -- ^ Дата, на которую рассчитан рейтинг. __API NOTE__: должен быть Day (например, @/teams/1/rating@ возвращает пустую строку для релиза 26; причём @/teams/1/rating/26@ возвращает пустой ответ) + , rat_formula :: RatingFormula -- ^ Формула подсчёта рейтинга + } deriving (Eq,Show,Read,Generic) + +instance FromJSON TeamRating where + parseJSON = genericParseJSON $ jsonOpts '_' 4 +instance ToJSON TeamRating where + toJSON = genericToJSON $ jsonOpts '_' 4 + toEncoding = genericToEncoding $ jsonOpts '_' 4 + +-- | Тип турнира +-- +-- __API NOTE__: типа @""@ (пустая строка) быть не должно. На данный момент (2019-01-13) таких турниров три: 2864, 2937, 2995. Типа @Неизвестный@ тоже быть не должно. Такой один: 2186 +data TournamentType + = Synchronous -- ^ Синхрон + | StrictlySynchronous -- ^ Строго синхронный + | Asynchronous -- ^ Асинхрон + | Casual -- ^ Обычный + | Regional -- ^ Региональный + | Marathon -- ^ Марафон + | TotalScore -- ^ Общий зачёт + | TypeUnknown -- ^ Неизвестный + | TypeEmpty -- ^ (пустая строка) + deriving (Eq,Show,Read,Generic) + +tournamentTypes :: [(Text, TournamentType)] +tournamentTypes = + [ ("Синхрон" , Synchronous) + , ("Строго синхронный", StrictlySynchronous) + , ("Асинхрон" , Asynchronous) + , ("Обычный" , Casual) + , ("Региональный" , Regional) + , ("Марафон" , Marathon) + , ("Общий зачёт" , TotalScore) + , ("Неизвестный" , TypeUnknown) + , ("" , TypeEmpty) + ] + +tournamentTypenames :: [(TournamentType, Text)] +tournamentTypenames = map swap tournamentTypes + +instance FromJSON TournamentType where + parseJSON = withText "TournamentType should be String" $ \t -> case lookup t tournamentTypes of + Nothing -> fail $ "Wrong TournamentType: " ++ T.unpack t + Just tt -> pure tt + +instance ToJSON TournamentType where + 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 + +-- | Короткая информация о турнире (в списке турниров) +data TournamentShort = TournamentShort + { trs_idtournament :: TournamentId -- ^ Идентификатор турнира. __API NOTE__: должен быть Int + , trs_name :: Text -- ^ Название турнира + , trs_dateStart :: LocalTime -- ^ Дата начала турнира (в часовом поясе МСК) + , trs_dateEnd :: LocalTime -- ^ Дата окончания турнира (в часовом поясе МСК) + , trs_typeName :: TournamentType -- ^ Тип турнира + } deriving (Eq,Show,Read,Generic) + +instance FromJSON TournamentShort where + parseJSON = genericParseJSON $ jsonOpts '_' 4 +instance ToJSON TournamentShort where + toJSON = genericToJSON $ jsonOpts '_' 4 + toEncoding = genericToEncoding $ jsonOpts '_' 4 + +-- | Полная информация о турнире (по отдельному запросу) +-- +-- Тип 'Tournament' можно было бы объединить с 'TournamentShort', однако, в этом +-- случае бóльшая часть полей имела бы тип 'Maybe' x, что подразумевало бы +-- другой смысл, с менее строгой проверкой типов (некоторые поля могут быть +-- установлены, а некоторые нет). Поэтому было решено разделить эти два типа. +-- +-- Сконвертировать 'Tournament' в 'TournamentShort' можно при помощи функции +-- 'tournamentToShort'. +-- +-- В отличие от 'Tournament' в типах 'Player' и 'Team' есть единственное поле, +-- которое устанавливается в запросе более полной информации, поэтому эти типы +-- не разделены на два. +data Tournament = Tournament + { trn_idtournament :: TournamentId -- ^ Идентификатор турнира. __API NOTE__: должен быть Int + , trn_name :: Text -- ^ Название турнира + , trn_town :: Text -- ^ Город проведения + , trn_longName :: Text -- ^ Длинное название турнира + , trn_dateStart :: LocalTime -- ^ Дата начала турнира (в часовом поясе МСК) + , trn_dateEnd :: LocalTime -- ^ Дата окончания турнира (в часовом поясе МСК) + , trn_tournamentInRating :: Text -- ^ Учитывается ли турнир в рейтинге. __API NOTE__: должен быть Bool + , trn_tourCount :: Text -- ^ Количество туров. __API NOTE__: должен быть Int + , trn_tourQuestions :: Text -- ^ Количество вопросов в туре. __API NOTE__: должен быть Int + , trn_tourQuestPerTour :: Maybe Text -- ^ Количество вопросов по турам, разделённое запятой. __API NOTE__: должен быть [Int] + , trn_questionsTotal :: Text -- ^ Количество вопросов общее. __API NOTE__: должен быть Int + , trn_typeName :: TournamentType -- ^ Тип турнира + , trn_mainPaymentValue :: Text -- ^ Размер обычного взноса + , trn_mainPaymentCurrency :: Text -- ^ Валюта обычного взноса + , trn_discountedPaymentValue :: Text -- ^ Размер льготного взноса + , trn_discountedPaymentCurrency :: Text -- ^ Валюта льготного взноса + , trn_discountedPaymentReason :: Text -- ^ Кому доступен льготный взнос + , trn_dateRequestsAllowedTo :: Text -- ^ Дата, до которой разрешена подача заявок. __API NOTE__: должен быть Day + , trn_comment :: Text -- ^ Комментарий (это __не__ текст внизу на странице турнира; например, в турнире 5003 комментарий пуст, хотя текст внизу гласит «Сроки турнира привязаны к Новому году и финалу года телеЧГК») + , trn_siteUrl :: Text -- ^ Адрес официального сайта + } deriving (Eq,Show,Read,Generic) + +instance FromJSON Tournament where + parseJSON = genericParseJSON $ jsonOpts '_' 4 +instance ToJSON Tournament where + toJSON = genericToJSON $ jsonOpts '_' 4 + toEncoding = genericToEncoding $ jsonOpts '_' 4 + +-- | Преобразует 'Tournament' в 'TournamentShort', убирая лишние поля +tournamentToShort :: Tournament -> TournamentShort +tournamentToShort Tournament{ trn_idtournament = idtournament + , trn_name = name + , trn_dateStart = dateStart + , trn_dateEnd = dateEnd + , trn_typeName = typeName + } + = TournamentShort { trs_idtournament = idtournament + , trs_name = name + , trs_dateStart = dateStart + , trs_dateEnd = dateEnd + , trs_typeName = typeName + } + +-- | Результаты турнира для команды +data TournamentResult = TournamentResult + { tr_idteam :: TeamId -- ^ Идентификатор команды. __API NOTE__: должен быть Int + , tr_current_name :: Text -- ^ Название команды на турнире. Может совпадать с основным названием. Если название разовое, отличается от основного названия + , tr_base_name :: Text -- ^ Основное название команды. + , tr_position :: Text -- ^ Положение в турнирной таблице. __API NOTE__: должен быть Int or Rational + , tr_questions_total :: Text -- ^ Общее количество взятых вопросов. __API NOTE__: должен быть Int + , tr_mask :: Text -- ^ Расплюсовка команды (строка, где на каждый вопрос турнира указано: @0@ - не взят; @1@ - взят; @X@ - вопрос снят). __API NOTE__: должен быть [Bool] or [Answer] + , tr_tech_rating :: Text -- ^ Технический рейтинг команды. __API NOTE__: должен быть Int + , tr_predicted_position :: Text -- ^ Предсказанное положение в турнирной таблице. __API NOTE__: должен быть Int or Rational + , tr_bonus_a :: Text -- ^ Бонус по формуле А (аддитивной). __API NOTE__: должен быть Int + , tr_bonus_b :: Text -- ^ Бонус по формуле Б (балансной). __API NOTE__: должен быть Int + , tr_diff_bonus :: Text -- ^ Разностный балл D. __API NOTE__: должен быть Int + , tr_included_in_rating :: Text -- ^ Результаты команды будут учтены в релизе. __API NOTE__: должен быть Bool + } deriving (Eq,Show,Read,Generic) + +instance FromJSON TournamentResult where + parseJSON = genericParseJSON $ jsonOpts '_' 3 +instance ToJSON TournamentResult where + toJSON = genericToJSON $ jsonOpts '_' 3 + toEncoding = genericToEncoding $ jsonOpts '_' 3 + +-- | Информация об игроке в составе команды на турнире +-- +-- __API NOTE__. Так как игрок не может быть одновременно в базовом составе и легионером, нужно заменить эти два поля одним. +data RecapPlayer = RecapPlayer + { rp_idplayer :: PlayerId -- ^ Идентификатор игрока. __API NOTE__: должен быть Int + , rp_is_captain :: Text -- ^ Является ли игрок капитаном (К). __API NOTE__: должен быть Bool + , rp_is_base :: Text -- ^ Находится ли игрок в базовом составе (Б). __API NOTE__: должен быть Bool + , rp_is_foreign :: Text -- ^ Является ли игрок легионером (Л). __API NOTE__: должен быть Bool + } deriving (Eq,Show,Read,Generic) + +instance FromJSON RecapPlayer where + parseJSON = genericParseJSON $ jsonOpts '_' 3 +instance ToJSON RecapPlayer where + toJSON = genericToJSON $ jsonOpts '_' 3 + toEncoding = genericToEncoding $ jsonOpts '_' 3 + +-- | Результаты команды по турам +data TourResult = TourResult + { tor_tour :: Text -- ^ Номер тура. __API NOTE__: должен быть Int + , tor_mask :: [Text] -- ^ Расплюсовка команды (количество элементов списка совпадает с количеством вопросов в туре; каждый элемент списка либо @0@ - не взят, либо @1@ - взят, либо @X@ - вопрос снят). __API NOTE__: должен быть [Int] or [Answer] + } deriving (Eq,Show,Read,Generic) + +instance FromJSON TourResult where + parseJSON = genericParseJSON $ jsonOpts '_' 4 +instance ToJSON TourResult where + toJSON = genericToJSON $ jsonOpts '_' 4 + toEncoding = genericToEncoding $ jsonOpts '_' 4 + +-- | Статус спорного или апелляции +data ClaimStatus + = ClaimNew -- ^ Новый (N) + | ClaimAccepted -- ^ Принят (A) + | ClaimRejected -- ^ Отклонён (D) + deriving (Eq,Show,Read,Generic) + +claimTypeText :: [(ClaimStatus, Text)] +claimTypeText = + [ (ClaimNew, "N") + , (ClaimAccepted, "A") + , (ClaimRejected, "D") + ] +claimTextType :: [(Text, ClaimStatus)] +claimTextType = map swap claimTypeText + +instance FromJSON ClaimStatus where + parseJSON = withText "ClaimStatus should be String" $ \t -> case lookup t claimTextType of + Nothing -> fail $ "Wrong ClaimStatus " ++ T.unpack t + Just tt -> pure tt + +instance ToJSON ClaimStatus where + toJSON tt = toJSON $ fromMaybe (error "Not all ClaimStatus have names") $ lookup tt claimTypeText + toEncoding tt = toEncoding $ fromMaybe (error "Not all ClaimStatus have names") $ lookup tt claimTypeText + +-- | Спорный +data Controversial = Controversial + { conQuestionNumber :: Text -- ^ Номер вопроса. __API NOTE__: должен быть @Int@ + , conAnswer :: Text -- ^ Ответ команды + , conIssuedAt :: LocalTime -- ^ Время подачи. __API NOTE__: должен быть @UTCTime@ + , conStatus :: ClaimStatus -- ^ Статус спорного + , conComment :: Text -- ^ Вердикт ИЖ + , conResolvedAt :: Text -- ^ Время вынесения решения. __API NOTE__: должен быть @UTCTime@ + , conAppealJuryComment :: Text -- ^ Вердикт АЖ + } deriving (Eq,Show,Read,Generic) + +instance FromJSON Controversial where + parseJSON = genericParseJSON $ jsonOpts '_' 3 +instance ToJSON Controversial where + toJSON = genericToJSON $ jsonOpts '_' 3 + toEncoding = genericToEncoding $ jsonOpts '_' 3 + +-- | Вид апелляции +data AppealType + = AppealApprove -- ^ Апелляция на зачёт ответа (A) + | AppealRemove -- ^ Апелляция на снятие вопроса (R) + | AppealNarrator -- ^ Апелляция на снятие из-за ошибки ведущего (N) + deriving (Eq,Show,Read,Generic) + +appealTypeText :: [(AppealType, Text)] +appealTypeText = + [ (AppealApprove, "A") + , (AppealRemove, "R") + , (AppealNarrator, "N") + ] +appealTextType :: [(Text, AppealType)] +appealTextType = map swap appealTypeText + +instance FromJSON AppealType where + parseJSON = withText "AppealType should be String" $ \t -> case lookup t appealTextType of + Nothing -> fail $ "Wrong AppealType " ++ T.unpack t + Just tt -> pure tt + +instance ToJSON AppealType where + toJSON tt = toJSON $ fromMaybe (error "Not all AppealType have names") $ lookup tt appealTypeText + toEncoding tt = toEncoding $ fromMaybe (error "Not all AppealType have names") $ lookup tt appealTypeText + +-- | Апелляция +data Appeal = Appeal + { appType :: AppealType -- ^ Тип апелляции + , appQuestionNumber :: Text -- ^ Номер вопроса + , appIssuedAt :: LocalTime -- ^ Время создания. __API NOTE__: должен быть @UTCTime@ + , appStatus :: ClaimStatus -- ^ Статус апелляции. Статус может быть "новая" и в том случае, если апелляция не рассмотрена, так как была зачтена другая апелляция + , appAppeal :: Text -- ^ Текст апелляции + , appComment :: Text -- ^ Вердикт АЖ + , appResolvedAt :: Text -- ^ Время публикации вердикта. __API NOTE__: должен быть @UTCTime@ + , appAnswer :: Text -- ^ Ответ команды + } deriving (Eq,Show,Read,Generic) + +instance FromJSON Appeal where + parseJSON = genericParseJSON $ jsonOpts '_' 3 +instance ToJSON Appeal where + toJSON = genericToJSON $ jsonOpts '_' 3 + toEncoding = genericToEncoding $ jsonOpts '_' 3 + +-- | Тип, описывающий API сайта рейтинга. Функции, которые позволяют делать запросы к API, находятся в модуле "RatingChgkInfo.Api" +-- +-- Некоторые замечания по общему дизайну API: +-- +-- * __API NOTE__: в запросах @\/players\/:id@, @\/tournaments\/:id@ и некоторых других должен возвращаться единственный результат вместо списка из одного результата +-- +-- * __API NOTE__: в запросе @\/players\/:id\/teams@ и других запросах, возвращающие элементы по сезонам, следует возвращать список вместо отображения номера сезона на элемент (идентификатор сезона дублируется в самом элементе) +-- +-- * __API NOTE__: запросы, возвращающие элементы по сезонам, и запрос @\/tournaments\/:tourn\/results\/:team@ устроены по-разному +-- +-- * __API NOTE__: запрос @\/teams\/:id\/rating\/:formula@, по-видимому, несколько сломан: для команды 1 он возвращает пустую строку (по состоянию на 2019-01-11) +-- +-- * __API NOTE__: запрос @\/players\/:id\/rating\/last@, по-видимому, нсколько сломан: для игрока 54345 он возвращает пустую строку (по состоянию на 2019-01-11) +-- +-- * __API NOTE__: запросы @\/tournament\/:id\/town\/:town@ должны использовать QueryParam вместо параметров путей +type RatingApi = "players" :> QueryParam "page" Int :> Get '[JSON] (Items Player) + :<|> "players" :> Capture "idplayer" PlayerId :> Get '[JSON] [Player] + :<|> "players" :> Capture "idplayer" PlayerId :> "teams" :> Get '[JSON] [PlayerTeam] -- TODO: Set? + :<|> "players" :> Capture "idplayer" PlayerId :> "teams" :> "last" :> Get '[JSON] [PlayerTeam] -- единственный элемент! + :<|> "players" :> Capture "idplayer" PlayerId :> "teams" :> Capture "idseason" Int :> Get '[JSON] [PlayerTeam] -- единственный элемент! + :<|> "players" :> Capture "idplayer" PlayerId :> "tournaments" :> Get '[JSON] (SeasonMap PlayerSeason) + :<|> "players" :> Capture "idplayer" PlayerId :> "tournaments" :> "last" :> Get '[JSON] PlayerSeason + :<|> "players" :> Capture "idplayer" PlayerId :> "tournaments" :> Capture "idseason" Int :> Get '[JSON] PlayerSeason + :<|> "players" :> Capture "idplayer" PlayerId :> "rating" :> Get '[JSON] [PlayerRating] -- TODO: Set? + :<|> "players" :> Capture "idplayer" PlayerId :> "rating" :> "last" :> Get '[JSON] PlayerRating + :<|> "players" :> Capture "idplayer" PlayerId :> "rating" :> Capture "idrelease" Int :> Get '[JSON] PlayerRating + :<|> "teams" :> QueryParam "page" Int :> Get '[JSON] (Items Team) + :<|> "teams" :> Capture "idteam" TeamId :> Get '[JSON] [Team] + :<|> "teams" :> Capture "idteam" TeamId :> "recaps" :> Get '[JSON] (SeasonMap TeamBaseRecap) + :<|> "teams" :> Capture "idteam" TeamId :> "recaps" :> "last" :> Get '[JSON] TeamBaseRecap + :<|> "teams" :> Capture "idteam" TeamId :> "recaps" :> Capture "idseason" Int :> Get '[JSON] TeamBaseRecap + :<|> "teams" :> Capture "idteam" TeamId :> "tournaments" :> Get '[JSON] (SeasonMap TeamTournament) + :<|> "teams" :> Capture "idteam" TeamId :> "tournaments" :> "last" :> Get '[JSON] TeamTournament + :<|> "teams" :> Capture "idteam" TeamId :> "tournaments" :> Capture "idseason" Int :> Get '[JSON] TeamTournament + :<|> "teams" :> Capture "idteam" TeamId :> "rating" :> Get '[JSON] [TeamRating] -- TODO: Set? + :<|> "teams" :> Capture "idteam" TeamId :> "rating" :> "a" :> Get '[JSON] TeamRating + :<|> "teams" :> Capture "idteam" TeamId :> "rating" :> "b" :> Get '[JSON] TeamRating + :<|> "teams" :> Capture "idteam" TeamId :> "rating" :> Capture "idrelease" Int :> Get '[JSON] TeamRating + :<|> "tournaments" :> QueryParam "page" Int :> Get '[JSON] (Items TournamentShort) + :<|> "tournaments" :> Capture "idtournament" TournamentId :> Get '[JSON] [Tournament] + :<|> "tournaments" :> Capture "idtournament" TournamentId :> "list" :> Get '[JSON] [TournamentResult] + :<|> "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" :> 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) + +-------------------------------------------------------------------------------- +-- Non-API Types + +-- | Название команды на турнире +data TeamName = TeamName + { tnTeamId :: Int -- ^ Идентификатор команды + , tnCurrentName :: Text -- ^ Название на турнире (может совпадать с основным) + , tnCurrentTown :: Text -- ^ Город приписки на турнире (может совпадать с основным) + , tnBaseName :: Text -- ^ Основное название + , tnBaseTown :: Text -- ^ Основной город прописки + } deriving (Eq,Show,Read,Generic) + +instance ToJSON TeamName where + toJSON = genericToJSON $ jsonOpts '-' 2 + toEncoding = genericToEncoding $ jsonOpts '-' 2 + +instance ToSchema TeamName where + declareNamedSchema p = genericDeclareNamedSchema (schemaOpts 2) p + & mapped.schema.title ?~ "TeamName" + & mapped.schema.description ?~ "Описание команды. В объекте содержатся поля: team-id - идентификатор команды; current-name - (разовое) название команды; current-town - (разовый) город приписки; base-name - название команды на сайте рейтинга; base-town - город приписки на сайте рейтинга" + +-- | Заявка на проведение +data Request = Request + { reqAccepted :: Maybe Bool -- ^ Заявка принята или отклонена + , reqTown :: Text -- ^ Город проведения + , reqRepresentativeId :: Int -- ^ Идентификатор представителя + , reqRepresentativeFullname :: Text -- ^ ФИО представителя + , reqNarratorId :: Int -- ^ Идентификатор ведущего (сайт рейтинга не экспортирует его в CSV, поэтому всегда установлен в 0) + , reqNarratorFullname :: Text -- ^ ФИО ведущего + , reqTeamsCount :: Int -- ^ Количество команд, которое было заявлено представителем + , reqTeams :: [TeamName] -- ^ Команды, введённые представителем + } deriving (Eq,Show,Read,Generic) + +instance ToJSON Request where + toJSON = genericToJSON $ jsonOpts '-' 3 + toEncoding = genericToEncoding $ jsonOpts '-' 3 + +instance ToSchema Request where + 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 - список введённых команд" + +jsonOpts :: Char -> Int -> Options +jsonOpts c k = defaultOptions { fieldLabelModifier = camelTo2 c . drop k } + +schemaOpts :: Int -> SchemaOptions +schemaOpts k = Swagger.defaultSchemaOptions + { Swagger.fieldLabelModifier = camelTo2 '-' . drop k + , Swagger.constructorTagModifier = camelTo2 '-' + , Swagger.unwrapUnaryRecords = True + } + diff --git a/src/RatingChgkInfo/Types/Unsafe.hs b/src/RatingChgkInfo/Types/Unsafe.hs new file mode 100644 --- /dev/null +++ b/src/RatingChgkInfo/Types/Unsafe.hs @@ -0,0 +1,87 @@ +{-| +Module : RatingChgkInfo.Types.Unsafe +Description : Небезопасные функции (в смысле безопасности типов) +Copyright : (c) Mansur Ziiatdinov, 2018-2019 +License : BSD-3 +Maintainer : chgk@pm.me +Stability : experimental +Portability : POSIX + +Из этого модуля экспортируются функции, которые не являются безопасными с точки зрения типов. + +Например, можно ошибиться и передать идентификатор игрока вместо идентификатора +команды, если оба идентификатора имеют текстовый тип. Чтобы избежать этого +класса ошибок мы используем разные типы для разных идентификаторов, а получить +значения-идентификаторы можно только из запросов к API. Ну, или если хочется +иметь возможность выстрелить в ногу — из этого модуля. Caveat emptor +-} + +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE OverloadedStrings #-} + +module RatingChgkInfo.Types.Unsafe + ( -- * Типы-идентификаторы + PlayerId (..) + , TeamId (..) + , TournamentId (..) + ) where + +import Control.Lens +import Data.Aeson +import Data.Swagger (ToSchema, declareNamedSchema, schema, description, ToParamSchema) +import Data.Text (Text) +import Servant.API + +-- | Идентификатор игрока. В API на самом деле возвращается строка, но во всех +-- функциях работы с игроками используется этот тип. Чтобы получить значение +-- этого типа следует получить данные из API +newtype PlayerId = PlayerId + { unPlayerId :: Text + } deriving (Eq,Show,Read,Generic,FromJSON,ToJSON,FromHttpApiData,ToHttpApiData) + +instance ToSchema PlayerId where + declareNamedSchema _p = declareNamedSchema (Proxy :: Proxy Text) + & mapped.schema.description ?~ "Идентификатор игрока" +instance ToParamSchema PlayerId + +-- | Идентификатор команды. В API на самом деле возвращается строка, но во всех +-- функциях работы с командами используется этот тип. Чтобы получить значение +-- этого типа следует получить данные из API +newtype TeamId = TeamId + { unTeamId :: Text + } deriving (Eq,Show,Read,Generic,FromJSON,ToJSON,FromHttpApiData,ToHttpApiData) + +instance ToSchema TeamId where + declareNamedSchema _p = declareNamedSchema (Proxy :: Proxy Text) + & mapped.schema.description ?~ "Идентификатор игрока" +instance ToParamSchema TeamId + +-- | Идентификатор турнира. В API на самом деле возвращается строка, но во всех +-- функциях работы с турнирами используется этот тип. Чтобы получить значение +-- этого типа следует получить данные из API +newtype TournamentId = TournamentId + { unTournamentId :: Text + } deriving (Eq,Show,Read,Generic,FromJSON,ToJSON,FromHttpApiData,ToHttpApiData) + +instance ToSchema TournamentId where + declareNamedSchema _p = declareNamedSchema (Proxy :: Proxy Text) + & mapped.schema.description ?~ "Идентификатор игрока" +instance ToParamSchema TournamentId + +-- | Идентификатор релиза. В API на самом деле возвращается строка, но во всех +-- функциях работы с релизами используется этот тип. Чтобы получить значение +-- этого типа следует получить данные из API +newtype ReleaseId = ReleaseId + { unReleaseId :: Text + } deriving (Eq,Show,Read,Generic,FromJSON,ToJSON,ToHttpApiData) + +-- | Идентификатор сезона. В API на самом деле возвращается строка, но во всех +-- функциях работы с сезонами используется этот тип. Чтобы получить значение +-- этого типа следует получить данные из API +newtype SeasonId = SeasonId + { unSeasonId :: Text + } deriving (Eq,Show,Read,Generic,FromJSON,ToJSON,ToHttpApiData) + +-- TODO: TownId, RegionId, CountryId + diff --git a/test/Spec.hs b/test/Spec.hs new file mode 100644 --- /dev/null +++ b/test/Spec.hs @@ -0,0 +1,3 @@ +main :: IO () +main = putStrLn ("Test suite not yet implemented" :: String) +