rating-chgk-info (empty) → 0.3.6.3
raw patch · 17 files changed
+2057/−0 lines, 17 filesdep +aesondep +base-nopreludedep +bytestringsetup-changed
Dependencies added: aeson, base-noprelude, bytestring, cassava, containers, gauge, http-client, iconv, lens, network, optparse-generic, rating-chgk-info, relude, servant, servant-client, servant-js, servant-server, servant-swagger, swagger2, text, time, vector, wai, warp, wreq
Files
- CHANGELOG.md +49/−0
- LICENSE +29/−0
- README.md +68/−0
- Setup.hs +2/−0
- app/extra-rating-api/Main.hs +7/−0
- benchmark/Main.hs +5/−0
- examples/GetAllClaims.hs +53/−0
- examples/Simple.hs +30/−0
- rating-chgk-info.cabal +216/−0
- src/Prelude.hs +8/−0
- src/RatingChgkInfo.hs +333/−0
- src/RatingChgkInfo/Api.hs +282/−0
- src/RatingChgkInfo/Extra.hs +66/−0
- src/RatingChgkInfo/NoApi.hs +194/−0
- src/RatingChgkInfo/Types.hs +625/−0
- src/RatingChgkInfo/Types/Unsafe.hs +87/−0
- test/Spec.hs +3/−0
+ CHANGELOG.md view
@@ -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+
+ LICENSE view
@@ -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.
+ README.md view
@@ -0,0 +1,68 @@+# rating-chgk-info++[](https://hackage.haskell.org/package/rating-chgk-info)+[](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)))++```
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ app/extra-rating-api/Main.hs view
@@ -0,0 +1,7 @@+module Main where++import RatingChgkInfo (extraRatingApiMain)++main :: IO ()+main = extraRatingApiMain+
+ benchmark/Main.hs view
@@ -0,0 +1,5 @@+import Gauge.Main++main :: IO ()+main = defaultMain [bench "const" (whnf const ())]+
+ examples/GetAllClaims.hs view
@@ -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))+
+ examples/Simple.hs view
@@ -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)))+
+ rating-chgk-info.cabal view
@@ -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+ +
+ src/Prelude.hs view
@@ -0,0 +1,8 @@+-- | Uses [relude](https://hackage.haskell.org/package/relude) as default Prelude.++module Prelude+ ( module Relude+ ) where++import Relude+
+ src/RatingChgkInfo.hs view
@@ -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 <port> | srv <sock>]"+
+ src/RatingChgkInfo/Api.hs view
@@ -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"+
+ src/RatingChgkInfo/Extra.hs view
@@ -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+
+ src/RatingChgkInfo/NoApi.hs view
@@ -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: [\"<html>" ->+ Left "No such tournament, returned html"+ "parse error (not enough input) at \"\"" ->+ Left "Not a synch, or no requests yet"+ _ -> Left $ B.pack err+ Right reqs -> case eteams of+ Left _ -> Right reqs+ Right teams -> Right $ M.elems $ combineTeamsRequests teams reqs+ _ -> Left $ r2 ^. responseStatus . statusMessage+ _ -> pure $ Left $ r1 ^. responseStatus . statusMessage+ where combineTeamsRequests ts rs = M.merge M.preserveMissing M.preserveMissing (M.zipWithMatched combine) (mkMap ts) (mkMap rs)+ mkMap = M.fromList . map fromReq+ fromReq req@(Request{ reqTown = town, reqRepresentativeFullname = rep }) = ((town,rep), req)+ combine+ (town, repFullname)+ Request{ reqRepresentativeId = repId+ , reqTeams = teams+ }+ Request{ reqAccepted = acc+ , reqNarratorFullname = narFullname+ , reqTeamsCount = n+ }+ = Request { reqAccepted = acc+ , reqTown = town+ , reqRepresentativeId = repId+ , reqRepresentativeFullname = repFullname+ , reqNarratorId = 0+ , reqNarratorFullname = narFullname+ , reqTeamsCount = n+ , reqTeams = teams+ }++-- Разбор заявок из CSV сайта рейтинга+parseRequests :: String -> ByteString -> Either String [Request]+parseRequests tid bs = decodeWith csvOpts HasHeader+ (convert "CP1251" "UTF-8" bs)+ >>= mapM csvRequestToRequest . toList+ where csvRequestToRequest CsvRequest{ crTown = town+ , crRepresentative = repName+ , crNarrator = narName+ , crStatus = status+ , crTeams = cnt }+ = let n = either (const (-1)) fst $ decimal $ snd $ T.breakOnEnd " / " cnt+ in Right $ Request+ { reqAccepted = case status of+ "Принята" -> Just True+ "Отказано" -> Just False+ "Новая" -> Nothing+ _ -> error $ T.concat ["Unknown request status in ", T.pack tid, ": ", status]+ , reqTown = town+ , reqRepresentativeId = 0+ , reqRepresentativeFullname = repName+ , reqNarratorId = 0+ , reqNarratorFullname = narName+ , reqTeamsCount = n+ , reqTeams = []+ }++-- Разбор команд из CSV сайта рейтинга+parseTeams :: ByteString -> Either String [Request]+parseTeams = fmap (map csvTeamGroupToRequest .+ groupBy ((==)`on`ctRepId) .+ toList) .+ decodeWith csvOpts HasHeader .+ convert "CP1251" "UTF-8"+ where csvTeamGroupToRequest cs@(cr:_) = Request+ { reqAccepted = Nothing -- only on page+ , reqTown = ctTown cr+ , reqRepresentativeId = fromMaybe 0 $ ctRepId cr+ , reqRepresentativeFullname = T.concat+ [ ctRepSurname cr+ , " "+ , ctRepName cr+ , " "+ , ctRepPatronym cr+ ]+ , reqNarratorId = 0 -- only on page+ , reqNarratorFullname = "" -- only on page+ , reqTeamsCount = 0 -- only on page+ , reqTeams = map ctToTeam cs+ }+ csvTeamGroupToRequest [] = error "Impossible happened: [] in csvTeamGroupToRequest"+ ctToTeam CsvTeam+ { ctTeamId = ident+ , ctTeam = current+ , ctTeamTown = curTown+ , ctTeamBaseName = base+ , ctTeamBaseTown = baseTown+ } = TeamName ident current curTown base baseTown++csvOpts :: DecodeOptions+csvOpts = defaultDecodeOptions+ { decDelimiter = fromIntegral $ ord ';'+ }+
+ src/RatingChgkInfo/Types.hs view
@@ -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+ }+
+ src/RatingChgkInfo/Types/Unsafe.hs view
@@ -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+
+ test/Spec.hs view
@@ -0,0 +1,3 @@+main :: IO ()+main = putStrLn ("Test suite not yet implemented" :: String)+