rating-chgk-info 0.3.6.3 → 0.3.6.4

raw patch · 6 files changed

+478/−15 lines, 6 filesdep +directorydep +http-client-tlsdep +tagsoupdep ~aesondep ~base-nopreludedep ~reludenew-component:exe:calendar-ratingPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependencies added: directory, http-client-tls, tagsoup

Dependency ranges changed: aeson, base-noprelude, relude, servant, servant-client, servant-server, text, time

API changes (from Hackage documentation)

Files

• CHANGELOG.md +18/−1
• app/calendar-rating/Main.hs +104/−0
• rating-chgk-info.cabal +31/−5
• src/RatingChgkInfo/Api.hs +99/−6
• src/RatingChgkInfo/NoApi.hs +146/−1
• src/RatingChgkInfo/Types.hs +80/−2

@@ -11,7 +11,24 @@ ## Fixed ## Security -# 0.3.6.3+# 0.3.6.4 - 2019-04-09++## Added++* Получение всех составов на турнире (API 3.6.4)+* Поиск по турнирам (API 3.6.4)+* Получение списка городов+* Получение ближайших синхронов в городе+* Приложение для генерации календарей синхронов в городе (app/calendar-rating)++## Changed++* Поля `archive` и `date_archived_at` в турнирах (API 3.6.4)+* Исправлены версии зависимостей, теперь они совместимы с GHC 8.6+* Работает с servant 0.16+* Данные запрашиваются через https++# 0.3.6.3 - 2019-02-09  ## Added 

@@ -0,0 +1,104 @@+{-# LANGUAGE OverloadedStrings #-}++import           RatingChgkInfo+import           RatingChgkInfo.Types.Unsafe (TournamentId (..), PlayerId (..))++import           Data.Aeson+import           Data.Text (Text)+import qualified Data.Text as T+import qualified Data.Text.IO as T+import           Data.Time+import           System.Directory (withCurrentDirectory)+import           System.Environment (getArgs)++main :: IO ()+main = do+  args <- getArgs+  case args of+    [rootDir, "town", townStr, town] -> withCurrentDirectory rootDir $ +      case readMaybe townStr of+        Nothing -> usage+        Just townId -> workTown townId (T.pack town) Nothing >>= mapM_ print+    [rootDir, townPagesStr] -> withCurrentDirectory rootDir $ +      case readMaybe townPagesStr of+        Nothing -> usage+        Just townPages -> work townPages+    _ -> usage++usage :: IO ()+usage = do+  die "Usage: calendar-rating <rootFolder> <townPages>"++work :: Int -> IO ()+work townPages = do+  ets <- fmap (fmap concat . sequence) $ forM [1..townPages] $ towns . Just+  case ets of+    Left err -> T.putStrLn $ decodeUtf8 err+    Right ts -> do+      ss <- forM ts $ \Town{ townId = ident, townName = town, townOtherName = other } -> do+        T.putStrLn town+        workTown ident town other+      encodeFile "names.json" $+        map fst $+        filter (not . null . snd) $+        zip ts ss++workTown :: Int -> Text -> Maybe Text -> IO [SynchTown]+workTown ident town other = do+  now <- getCurrentTime+  ests <- synchTown ident+  case ests of+    Left err -> T.putStrLn (decodeUtf8 err) >> pure []+    Right sts -> do+      let fname = "t" ++ show ident ++ ".ics"+      let events = filter ((==ClaimAccepted) . stStatus) sts+      unless (null events) $+        T.writeFile fname $ T.intercalate "\r\n"+        [ calStart+        , T.intercalate "\r\n" $+          map (mkEvent now town other) events+        , calEnd+        ]+      pure events++calStart :: Text+calStart = T.intercalate "\r\n"+  [ "BEGIN:VCALENDAR"+  , "VERSION:2.0"+  , "PRODID:-//calendar.chgk.me/EN"+  , "METHOD:PUBLISH"+  ]++calEnd :: Text+calEnd = "END:VCALENDAR"++mkEvent :: UTCTime -> Text -> Maybe Text -> SynchTown -> Text+mkEvent now town other SynchTown{ stTournamentId = TournamentId tid+                                , stTournament = tourn+                                , stRepresentativeId = PlayerId rid+                                , stRepresentative = rep+                                , stTime = time }+  = T.intercalate "\r\n"+    [ "BEGIN:VEVENT"+    , "UID:" `T.append` uid+    , "DTSTAMP:" `T.append` ts+    , "DTSTART;TZID=Europe/Moscow:" `T.append` start+    , "SUMMARY:" `T.append` summary+    , "ORGANIZER:" `T.append` org+    , "LOCATION:" `T.append` loc+    , "URL:" `T.append` url+    , "DESCRIPTION:" `T.append` desc+    , "END:VEVENT"+    ]+  where+    uid = T.concat [ "t", tid, "-r", rid, "@calendar.chgk.me" ]+    format :: FormatTime t => t -> Text+    format = T.pack . formatTime defaultTimeLocale "%Y%m%dT%H%M%S"+    ts = format now `T.append` "Z"+    start = format time+    summary = tourn+    org = rep+    loc = T.concat $ town : maybe [] pure other+    url = T.concat [ "https://rating.chgk.info/tournament/", tid ]+    desc = T.concat [ "Представитель: ", rep, "\\n", "Турнир: ", url]+

@@ -1,6 +1,6 @@ cabal-version:       1.24 name:                rating-chgk-info-version:             0.3.6.3+version:             0.3.6.4 synopsis:            Client for rating.chgk.info API and CSV tables (documentation in Russian) description:   Клиент для REST API сайта рейтинга (rating.chgk.info) и функциональности, которой нет в REST API, но которая доступна через экспорт CSV.@@ -80,23 +80,25 @@                        -fhide-source-paths                        -Wmissing-export-lists                        -Wpartial-fields-  build-depends:       base-noprelude == 4.11.*+  build-depends:       base-noprelude >= 4.11                      , relude >= 0.4.0                      , aeson >=1.4                      , bytestring >=0.10                      , cassava >=0.5                      , containers >=0.5                      , http-client >= 0.5+                     , http-client-tls >= 0.3                      , iconv >=0.4                      , lens >=4.17                      , network >=2.8                      , optparse-generic >=1.3-                     , servant >=0.15-                     , servant-client >=0.15+                     , servant >=0.16+                     , servant-client >=0.16                      , servant-js >=0.9-                     , servant-server >=0.15+                     , servant-server >=0.16                      , servant-swagger >=1.1                      , swagger2 >=2.2+                     , tagsoup >=0.14                      , text >=1.2                      , time >=1.8                      , vector >=0.12@@ -166,6 +168,30 @@   build-depends:       base-noprelude                      , rating-chgk-info                      , relude+  default-language:    Haskell2010+  +executable calendar-rating+  hs-source-dirs:      app/calendar-rating+  main-is:             Main.hs+  ghc-options:         -Wall+                       -threaded+                       -rtsopts+                       -with-rtsopts=-N+                       -Wincomplete-uni-patterns+                       -Wincomplete-record-updates+                       -Wcompat+                       -Widentities+                       -Wredundant-constraints+                       -fhide-source-paths+                       -Wmissing-export-lists+                       -Wpartial-fields+  build-depends:       base-noprelude+                     , rating-chgk-info+                     , relude+                     , aeson+                     , directory+                     , text+                     , time   default-language:    Haskell2010    

@@ -57,6 +57,7 @@   , tournamentResultsCountry   , tournamentTeamResult     -- ** Составы на турнире+  , tournamentRecaps   , tournamentRecap     -- ** Спорные и апелляции   , tournamentControversials@@ -66,13 +67,15 @@     -- $maybeParams   , teamSearch   , playerSearch+  , tournamentSearch     -- * Вспомогательные функции   , getAllItems   ) where  import RatingChgkInfo.Types -import Network.HTTP.Client (newManager,defaultManagerSettings)+import Network.HTTP.Client (newManager)+import Network.HTTP.Client.TLS (tlsManagerSettings) import Servant.API import Servant.Client @@ -80,157 +83,235 @@ api = Proxy  -- | Список всех игроков+--+-- Запрос @\/players@ players :: Maybe Int            -- ^ Номер страницы в результате         -> RatingClient (Items Player) -- ^ Список игроков, по 1000 элементов  -- | Информация об игроке -- -- __API NOTE__. Результат должен быть 'Player', а не список игроков из одного элемента+--+-- Запрос @\/players\/:id@ player :: PlayerId                   -- ^ Идентификатор игрока        -> RatingClient [Player] -- ^ Информация об игроке, список из единственного элемента  -- | Команды, в базовых составах которых играл игрок+--+-- Запрос @\/players\/:id\/teams@ playerTeams :: PlayerId              -- ^ Идентификатор игрока             -> RatingClient [PlayerTeam] -- ^ Список команд игрока  -- | Команды, в базовый состав которых игрок входит в текущем сезоне+--+-- Запрос @\/players\/:id\/teams\/last@ playerLastTeam :: PlayerId           -- ^ Идентификатор игрока                -> RatingClient [PlayerTeam] -- ^ Список команд игрока  -- | Команды, в базовый состав которых игрок входил в указанном сезоне+--+-- Запрос @\/players\/:id\/teams\/:season@ playerTeam :: PlayerId               -- ^ Идентификатор игрока            -> Int               -- ^ Идентификатор сезона            -> RatingClient [PlayerTeam] -- ^ Список команд игрока  -- | Турниры, которые отыграл игрок, по сезонам+--+-- Запрос @\/players\/:id\/tournaments@ playerTournaments :: PlayerId        -- ^ Идентификатор игрока                   -> RatingClient (SeasonMap PlayerSeason) -- ^ Турниры игрока по сезонам  -- | Турниры, которые игрок отыграл в текущем сезоне+--+-- Запрос @\/players\/:id\/tournaments\/last@ playerLastTournament :: PlayerId     -- ^ Идентификатор игрока                      -> RatingClient PlayerSeason  -- | Турниры, которые игрок отыграл в указанном сезоне+--+-- Запрос @\/players\/:id\/tournaments\/:season@ playerTournament :: PlayerId         -- ^ Идентификатор игрока                  -> Int         -- ^ Идентификатор сезона                  -> RatingClient PlayerSeason  -- | Рейтинги игрока+--+-- Запрос @\/players\/:id\/rating@ playerRatings :: PlayerId            -- ^ Идентификатор игрока               -> RatingClient [PlayerRating] -- ^ Список рейтингов игрока, порядок не определён  -- | Рейтинг игрока в последнем релизе -- -- __API NOTE__. Работает не всегда: например, для 54345 в декабре 2018 ничего не возвращало (off-by-one error?)+--+-- Запрос @\/players\/:id\/rating\/last@ playerLastRating :: PlayerId         -- ^ Идентификатор игрока                  -> RatingClient PlayerRating  -- | Рейтинг игрока в указанном релизе+--+-- Запрос @\/players\/:id\/rating\/:release@ playerRating :: PlayerId             -- ^ Идентификатор игрока              -> Int             -- ^ Идентификатор релиза              -> RatingClient PlayerRating  -- | Список всех команд+--+-- Запрос @\/teams@ teams :: Maybe Int              -- ^ Номер страницы в результате       -> RatingClient (Items Team) -- ^ Команды по 1000 элементов  -- | Информация о команде -- -- __API NOTE__: должна быть команда, а не список из команд+--+-- Запрос @\/teams\/:id@ team :: TeamId                     -- ^ Идентификатор команды      -> RatingClient [Team]     -- ^ Команда, список из единственного элемента  -- | Базовые составы команды+--+-- Запрос @\/teams\/:id\/recaps@ teamBaseRecaps :: TeamId           -- ^ Идентификатор команды                -> RatingClient (SeasonMap TeamBaseRecap) -- ^ Базовые составы по сезонам  -- | Базовый состав команды в последнем сезоне+--+-- Запрос @\/teams\/:id\/recaps\/last@ teamLastBaseRecap :: TeamId        -- ^ Идентификатор команды                   -> RatingClient TeamBaseRecap  -- | Базовый состав команды в указанном сезоне+--+-- Запрос @\/teams\/:id\/recaps\/:season@ teamBaseRecap :: TeamId            -- ^ Идентификатор команды               -> Int            -- ^ Идентификатор сезона               -> RatingClient TeamBaseRecap  -- | Турниры, отыгранные командой+--+-- Запрос @\/teams\/:id\/tournaments@ teamTournaments :: TeamId          -- ^ Идентификатор команды                 -> RatingClient (SeasonMap TeamTournament) -- ^ Турниры команды по сезонам  -- | Турниры, отыгранные командой в последнем сезоне+--+-- Запрос @\/teams\/:id\/tournaments\/last@ teamLastTournament :: TeamId       -- ^ Идентификатор команды                    -> RatingClient TeamTournament  -- | Турниры, отыгранные командой в указанном сезоне+--+-- Запрос @\/teams\/:id\/tournaments\/:season@ teamTournament :: TeamId           -- ^ Идентификатор команды                -> Int           -- ^ Идентификатор сезона                -> RatingClient TeamTournament  -- | Рейтинги команды+--+-- Запрос @\/teams\/:id\/rating@ teamRatings :: TeamId              -- ^ Идентификатор команды             -> RatingClient [TeamRating] -- ^ Список рейтингов команды, порядок не определён  -- | Последний рейтинг команды по формуле A -- -- __API NOTE__. Работает не всегда: для 1 ничего не возвращает (off-by-one error?)+--+-- Запрос @\/teams\/:id\/rating\/a@ teamRatingA :: TeamId              -- ^ Идентификатор команды             -> RatingClient TeamRating  -- | Последний рейтинг команды по формуле B -- -- __API NOTE__. Работает не всегда: для 1 ничего не возвращает (off-by-one error?)+--+-- Запрос @\/teams\/:id\/rating\/b@ teamRatingB :: TeamId              -- ^ Идентификатор команды             -> RatingClient TeamRating  -- | Рейтинг команды в указанном релизе+--+-- Запрос @\/teams\/:id\/rating\/:release@ teamRating :: TeamId               -- ^ Идентификатор команды            -> Int               -- ^ Идентификатор релиза            -> RatingClient TeamRating  -- | Список всех турниров-tournaments :: Maybe Int        -- ^ Номер страницы в результате+--+-- Запрос @\/tournaments@+tournaments :: Maybe Int        -- ^ Номер страницы (@page@) в результате             -> RatingClient (Items TournamentShort) -- ^ Информация о турнирах по 1000 элементов  -- | Информация о турнире -- -- __API NOTE__: должен быть турнир, а не список турниров+--+-- Запрос @\/tournaments\/:id@ tournament :: TournamentId               -- ^ Идентификатор турнира            -> RatingClient [Tournament] -- ^ Единственный элемент списка - турнир  -- | Результаты турнира+--+-- Запрос @\/tournaments\/:id\/list@ tournamentResults :: TournamentId        -- ^ Идентификатор турнира                   -> RatingClient [TournamentResult] -- ^ Результаты по командам, порядок не определён  -- | Результаты турнира для команд города+--+-- Запрос @\/tournaments\/:id\/list\/town\/:town@ tournamentResultsTown :: TournamentId        -- ^ Идентификатор турнира                       -> Int        -- ^ Идентификатор города                       -> RatingClient [TournamentResult] -- ^ Результаты по командам, порядок не определён  -- | Результаты турнира для команд региона+--+-- Запрос @\/tournaments\/:id\/list\/region\/:region@ tournamentResultsRegion :: TournamentId        -- ^ Идентификатор турнира                         -> Int        -- ^ Идентификатор региона                         -> RatingClient [TournamentResult] -- ^ Результаты по командам, порядок не определён  -- | Результаты турнира для команд страны+--+-- Запрос @\/tournaments\/:id\/list\/country\/:country@ tournamentResultsCountry :: TournamentId        -- ^ Идентификатор турнира                          -> Int        -- ^ Идентификатор страны                          -> RatingClient [TournamentResult] -- ^ Результаты по командам, порядок не определён +-- | Составы команд на турнире+--+-- Запрос @\/tournaments\/:id\/recaps@+--+-- @since 0.3.6.4+tournamentRecaps :: TournamentId -- ^ Идентификаторр турнира+                 -> RatingClient [RecapTeam]+ -- | Составы указанной команды на турнире+--+-- Запрос @\/tournaments\/:id\/recaps\/:team@ tournamentRecap :: TournamentId          -- ^ Идентификатор турнира                 -> TeamId          -- ^ Идентификатор команды                 -> RatingClient [RecapPlayer] -- ^ Список игроков с флагами К\/Б\/Л  -- | Результат указанной команды на турнире+--+-- Запрос @\/tournaments\/:id\/results\/:team@ tournamentTeamResult :: TournamentId     -- ^ Идентификатор турнира                      -> TeamId     -- ^ Идентификатор команды                      -> RatingClient [TourResult] -- ^ Список результатов по турам  -- | Спорные на турнире+--+-- Запрос @\/tournaments\/:id\/controversials@+--+-- @since 0.3.6.3 tournamentControversials :: TournamentId -- ^ Идентификатор турнира                          -> RatingClient [Controversial] -- ^ Спорные  -- | Апелляции на турнире+--+-- Запрос @\/tournaments\/:id\/appeals@+--+-- @since 0.3.6.3 tournamentAppeals :: TournamentId -- ^ Идентификатор турнира                   -> RatingClient [Appeal] -- ^ Апелляции @@ -242,6 +323,8 @@ -- связки И.  -- | Поиск по командам+--+-- Запрос @\/teams\/search@ teamSearch :: Maybe Text        -- ^ Название (name)            -> Maybe Text        -- ^ Город (town)            -> Maybe Text        -- ^ Регион (region_name)@@ -251,14 +334,24 @@            -> RatingClient (Items Team)     -- ^ Список команд по 1000 элементов  -- | Поиск по игрокам+--+-- Запрос @\/players\/search@ playerSearch :: Maybe Text      -- ^ Фамилия              -> Maybe Text      -- ^ Имя              -> Maybe Text      -- ^ Отчество              -> Maybe Int       -- ^ Номер страницы в результате              -> RatingClient (Items Player) -- ^ Список игроков по 1000 элементов -players :<|> player :<|> playerTeams :<|> playerLastTeam :<|> playerTeam :<|> playerTournaments :<|> playerLastTournament :<|> playerTournament :<|> playerRatings :<|> playerLastRating :<|> playerRating :<|> teams :<|> team :<|> teamBaseRecaps :<|> teamLastBaseRecap :<|> teamBaseRecap :<|> teamTournaments :<|> teamLastTournament :<|> teamTournament :<|> teamRatings :<|> teamRatingA :<|> teamRatingB :<|> teamRating :<|> tournaments :<|> tournament :<|> tournamentResults :<|> tournamentResultsTown :<|> tournamentResultsRegion :<|> tournamentResultsCountry :<|> tournamentRecap :<|> tournamentTeamResult :<|> tournamentControversials :<|> tournamentAppeals :<|> teamSearch :<|> playerSearch = client api+-- | Поиск по турнирам+--+-- Запрос @\/tournaments\/search@+tournamentSearch :: Maybe TournamentType -- ^ Тип турнира+                 -> Maybe Int            -- ^ Находится ли турнир в архиве (0 - не находится, 1 - находится)+                 -> Maybe Int            -- ^ Номер страницы в результате+                 -> RatingClient (Items TournamentShort) +players :<|> player :<|> playerTeams :<|> playerLastTeam :<|> playerTeam :<|> playerTournaments :<|> playerLastTournament :<|> playerTournament :<|> playerRatings :<|> playerLastRating :<|> playerRating :<|> teams :<|> team :<|> teamBaseRecaps :<|> teamLastBaseRecap :<|> teamBaseRecap :<|> teamTournaments :<|> teamLastTournament :<|> teamTournament :<|> teamRatings :<|> teamRatingA :<|> teamRatingB :<|> teamRating :<|> tournaments :<|> tournament :<|> tournamentResults :<|> tournamentResultsTown :<|> tournamentResultsRegion :<|> tournamentResultsCountry :<|> tournamentRecaps :<|> tournamentRecap :<|> tournamentTeamResult :<|> tournamentControversials :<|> tournamentAppeals :<|> teamSearch :<|> playerSearch :<|> tournamentSearch = client api+ -- | Получение всех элементов из запроса с разбиением по страницам -- -- В функции предполагается, что сайт рейтинга, как и указано в документации,@@ -275,8 +368,8 @@ -- -- Все запросы внутри 'RatingClient' используют один и тот же менеджер соединений runRatingApi :: RatingClient a -- ^ Набор команд, работающих с API сайта рейтинга-             -> IO (Either ServantError a) -- ^ Результат работы, либо ошибка+             -> IO (Either ClientError a) -- ^ Результат работы, либо ошибка runRatingApi act = do-  mgr <- newManager defaultManagerSettings-  runClientM act $ mkClientEnv mgr $ BaseUrl Http "rating.chgk.info" 80 "api"+  mgr <- newManager tlsManagerSettings+  runClientM act $ mkClientEnv mgr $ BaseUrl Https "rating.chgk.info" 443 "api" 

@@ -17,25 +17,32 @@  module RatingChgkInfo.NoApi   ( requests+  , synchTown+  , towns   ) where  import           Prelude hiding (ByteString, get)  import           RatingChgkInfo.Types-import           RatingChgkInfo.Types.Unsafe (TournamentId (..))+import           RatingChgkInfo.Types.Unsafe (TournamentId (..), PlayerId (..))  import           Codec.Text.IConv import           Control.Lens import qualified Data.ByteString.Char8 as B import           Data.ByteString.Lazy.Char8 (ByteString)+import qualified Data.ByteString.Lazy.Char8 as BL+import           Data.Char import           Data.Csv+import           Data.Fixed import           Data.List import qualified Data.Map as M import qualified Data.Map.Merge.Lazy as M import           Data.Text (Text) import qualified Data.Text as T import           Data.Text.Read+import           Data.Time import           Network.Wreq+import           Text.HTML.TagSoup  -- Команда в CSV data CsvTeam = CsvTeam@@ -191,4 +198,142 @@ csvOpts = defaultDecodeOptions   { decDelimiter = fromIntegral $ ord ';'   }++-- | Получает список предстоящих синхронов в городе+--+-- @since 0.3.6.4+synchTown :: Int                -- ^ Идентификатор города+          -> IO (Either B.ByteString [SynchTown]) -- ^ Ошибка или список синхронов в городе+synchTown townId = do+  let url = "https://rating.chgk.info/jq_backend/synch.php?upcoming_synch=true&town_id=" ++ show townId+  -- TODO: better use: https://rating.chgk.info/synch_town/<townId>+  r <- get url+  pure $ case r^.responseStatus.statusCode of+    200 -> parseSynchTown $ r^.responseBody+    _ -> Left $ r^.responseStatus.statusMessage++parseSynchTown :: ByteString -> Either B.ByteString [SynchTown]+parseSynchTown body = let+  tags = parseTags $+         convert "CP1251" "UTF-8" body :: [Tag ByteString]+  tbodyTagName = "tbody" :: ByteString+  tbody = takeWhile (\t -> t ~/= TagClose tbodyTagName) $+          dropWhile (\t -> t ~/= TagOpen tbodyTagName []) $+          mapMaybe trimTags tags+  trName = "tr" :: ByteString+  tdName = "td" :: ByteString+  cols = map (partitions (\t -> t ~== TagOpen tdName [])) $+         partitions (\t -> t ~== TagOpen trName []) tbody+  in mapM parseSynchTownRow cols++trimTags :: Tag ByteString -> Maybe (Tag ByteString)+trimTags (TagText t) = case BL.dropWhile isSpace t of+  "" -> Nothing+  u -> Just $ TagText $ BL.reverse $ BL.dropWhile isSpace $ BL.reverse u+trimTags t = Just t++parseSynchTownRow :: [[Tag ByteString]] -> Either B.ByteString SynchTown+parseSynchTownRow [syn, stat, rep, time] = do+  let listToEither s [] = Left s+      listToEither _ (x:_) = Right x+      toClaimStatus "Заявка не рассмотрена" = Right ClaimNew+      toClaimStatus "Заявка принята" = Right ClaimAccepted+      toClaimStatus "Заявка отклонена" = Right ClaimRejected+      toClaimStatus s = Left $ B.pack $ "Wrong claim status " ++ T.unpack s+  synHref <- fmap (TournamentId . decodeUtf8 . BL.drop 12 . fromAttrib "href") $+             listToEither "Can't find href for synch id in synchTown" $+             filter (isTagOpenName "a") syn+  synText <- fmap (decodeUtf8 . fromTagText) $+             listToEither "Can't find synch name in synchTown" $+             filter isTagText syn+  statI <- fmap (decodeUtf8 . fromAttrib "title") $+           listToEither "Can't find i for status in synchTown" $+           filter (isTagOpenName "i") stat+  status <- toClaimStatus statI+  repHref <- fmap (PlayerId . decodeUtf8 . BL.drop 8 . fromAttrib "href") $+             listToEither "Can't find href for rep id in synchTown" $+             filter (isTagOpenName "a") rep+  repName <- fmap (decodeUtf8 . fromTagText) $+             listToEither "Can't find rep name in synchTown" $+             filter isTagText rep+  timeText <- fmap (decodeUtf8 . fromTagText) $+              listToEither "Can't find time in synchTown" $+              filter isTagText time+  tim <- parseTimeText timeText+  pure $ SynchTown synHref synText status repHref repName tim+parseSynchTownRow _ = Left "Html changed in synchTown, please report to chgk@pm.me"++parseTimeText :: Text -> Either B.ByteString LocalTime+parseTimeText t = case T.words t of+  [dStr,monStr,yStr,timeStr] -> case T.split (==':') timeStr of+    [hStr,mStr,sStr] -> do+      d <- eparse "Can't parse day" dStr+      mon<-emonth monStr+      y <- eparse "Can't parse year" yStr+      h <- eparse "Can't parse hour" hStr+      m <- eparse "Can't parse min" mStr+      s <- eparse "Can't parse sec" sStr+      pure $ LocalTime (fromGregorian y mon d) (TimeOfDay h m $ MkFixed $ s * (resolution (MkFixed 0 :: Pico)))+    _ -> Left "Can't parse time"+  _ -> Left "Can't parse date"+  where eparse e t = case decimal t of+          Left _ -> Left e+          Right (n,_) -> Right n+        emonth m = case elemIndex m months of+          Nothing -> Left "Can't parse month"+          Just v -> Right $ v+1+        months = ["января", "февраля", "марта", "апреля", "мая", "июня", "июля", "августа", "сентября", "октября", "ноября", "декабря"]++-- | Получает список городов+--+-- @since 0.3.6.4+towns :: Maybe Int                       -- ^ Номер страницы (если не задан - первая)+      -> IO (Either B.ByteString [Town]) -- ^ Ошибка или список городов+towns mpage = do+  let url = "https://rating.chgk.info/geo.php?layout=town_list" ++ maybe "" (("&page=" ++) . show) mpage+  r <- get url+  pure $ case r^.responseStatus.statusCode of+    200 -> parseTown $ r^.responseBody+    _ -> Left $ r^.responseStatus.statusMessage++parseTown :: ByteString -> Either B.ByteString [Town]+parseTown body = let+  tags = parseTags $+         convert "CP1251" "UTF-8" body :: [Tag ByteString]+  tbodyTagName = "tbody" :: ByteString+  tbody = takeWhile (\t -> t ~/= TagClose tbodyTagName) $+          dropWhile (\t -> t ~/= TagOpen tbodyTagName []) $+          mapMaybe trimTags tags+  trName = "tr" :: ByteString+  tdName = "td" :: ByteString+  cols = map (partitions (\t -> t ~== TagOpen tdName [])) $+         partitions (\t -> t ~== TagOpen trName []) tbody+  in mapM parseTownRow cols++parseTownRow :: [[Tag ByteString]] -> Either B.ByteString Town+parseTownRow [identT, nameT, regionT, countryT, _countT] = do+  let listToEither s [] = Left s+      listToEither _ (x:_) = Right x+      toId c t = case decimal t of+        Left e -> Left $ B.pack e+        Right (n,_) -> Right $ c n+  identText <- fmap (decodeUtf8 . fromTagText) $+               listToEither "Can't find ident in towns" $+               filter isTagText identT+  ident <- toId id identText+  let (townT, otherT) = span (\t -> t ~/= TagOpen ("span" :: ByteString) []) nameT+  town <- fmap (decodeUtf8 . fromTagText) $+          listToEither "Can't find town in towns" $+          filter isTagText townT+  other <- case filter (isTagOpenName "a") otherT of+    [] -> Right Nothing+    (t:_) -> Right $ Just $ decodeUtf8 $ fromAttrib "title" t+  region <- case filter isTagText regionT of+    [] -> Right Nothing+    (t:_) -> Right $ Just $ decodeUtf8 $ fromTagText t+  country <- case filter isTagText countryT of+    [] -> Right Nothing+    (t:_) -> Right $ Just $ decodeUtf8 $ fromTagText t+  pure $ Town ident town other region country+parseTownRow _ = Left "Html changed in synchTown, please report to chgk@pm.me" 

@@ -47,12 +47,17 @@   , TeamTournament(..)   , TeamRating(..)     -- ** Турнир+    -- *** Общая информация о турнире   , TournamentShort(..)   , Tournament(..)   , tournamentToShort-  , TournamentResult(..)+    -- *** Составы+  , RecapTeam(..)   , RecapPlayer(..)+    -- *** Результаты+  , TournamentResult(..)   , TourResult(..)+    -- *** Спорные и апелляции   , Controversial (..)   , Appeal (..)     -- ** Типы-перечисления@@ -81,8 +86,13 @@     --     -- Функции для работы с этими типами находятся в модуле "RatingChgkInfo.NoApi"     --+  -- ** Заявки на турниры   , Request(..)   , TeamName(..)+  -- ** География+  , Town (..)+  -- ** Синхроны в городе+  , SynchTown(..)   ) where  import           RatingChgkInfo.Types.Unsafe@@ -313,6 +323,10 @@   toJSON tt = toJSON $ fromMaybe (error "Not all tournamentTypes have names") $ lookup tt tournamentTypenames   toEncoding tt = toEncoding $ fromMaybe (error "Not all tournamentTypes have names") $ lookup tt tournamentTypenames +instance ToHttpApiData TournamentType where+  toUrlPiece tt = toUrlPiece $ fromMaybe (error "Not all tournamentTypes have names") $ lookup tt tournamentTypenames+  toQueryParam tt = toQueryParam $ fromMaybe (error "Not all tournamentTypes have names") $ lookup tt tournamentTypenames+ -- | Короткая информация о турнире (в списке турниров) data TournamentShort = TournamentShort   { trs_idtournament :: TournamentId    -- ^ Идентификатор турнира. __API NOTE__: должен быть Int@@ -320,6 +334,14 @@   , trs_dateStart :: LocalTime  -- ^ Дата начала турнира (в часовом поясе МСК)   , trs_dateEnd :: LocalTime    -- ^ Дата окончания турнира (в часовом поясе МСК)   , trs_typeName :: TournamentType -- ^ Тип турнира+  , trs_archive :: Text+    -- ^ Архивирован ли турнир (0 - нет, 1 - да, пустая строка - турнир слишком давний). __API NOTE__: должен быть Bool+    --+    -- @since 0.3.6.4+  , trs_dateArchivedAt :: Day+    -- ^ Дата занесения в архив (может быть пустая строка). __API NOTE__: должен быть Maybe UTCTime+    --+    -- @since 0.3.6.4   } deriving (Eq,Show,Read,Generic)  instance FromJSON TournamentShort where@@ -362,6 +384,14 @@   , trn_dateRequestsAllowedTo :: Text     -- ^ Дата, до которой разрешена подача заявок. __API NOTE__: должен быть Day   , trn_comment :: Text                   -- ^ Комментарий (это __не__ текст внизу на странице турнира; например, в турнире 5003 комментарий пуст, хотя текст внизу гласит «Сроки турнира привязаны к Новому году и финалу года телеЧГК»)   , trn_siteUrl :: Text                   -- ^ Адрес официального сайта+  , trn_archive :: Text+    -- ^ Архивирован ли турнир (0 - нет, 1 - да, пустая строка - турнир слишком давний). __API NOTE__: должен быть Bool+    --+    -- @since 0.3.6.4+  , trn_dateArchivedAt :: Day+    -- ^ Дата занесения в архив (может быть пустая строка). __API NOTE__: должен быть Maybe UTCTime+    --+    -- @since 0.3.6.4   } deriving (Eq,Show,Read,Generic)  instance FromJSON Tournament where@@ -377,12 +407,16 @@                             , trn_dateStart = dateStart                             , trn_dateEnd = dateEnd                             , trn_typeName = typeName+                            , trn_archive = archive+                            , trn_dateArchivedAt = dateArchived                             }   = TournamentShort { trs_idtournament = idtournament                     , trs_name = name                     , trs_dateStart = dateStart                     , trs_dateEnd = dateEnd                     , trs_typeName = typeName+                    , trs_archive = archive+                    , trs_dateArchivedAt = dateArchived                     }  -- | Результаты турнира для команды@@ -409,7 +443,7 @@  -- | Информация об игроке в составе команды на турнире ----- __API NOTE__. Так как игрок не может быть одновременно в базовом составе и легионером, нужно заменить эти два поля одним.+-- __API NOTE__. Так как игрок не может быть одновременно в базовом составе и легионером, нужно заменить эти два поля одним, либо описать, когда игрок может не быть ни базовым, ни легионером data RecapPlayer = RecapPlayer   { rp_idplayer :: PlayerId -- ^ Идентификатор игрока. __API NOTE__: должен быть Int   , rp_is_captain :: Text       -- ^ Является ли игрок капитаном (К). __API NOTE__: должен быть Bool@@ -423,6 +457,18 @@   toJSON = genericToJSON $ jsonOpts '_' 3   toEncoding = genericToEncoding $ jsonOpts '_' 3 +-- | Состав команды на турнире+data RecapTeam = RecapTeam+  { rt_idteam :: TeamId         -- ^ Идентификатор команды. __API NOTE__: должен быть Int+  , rt_recaps :: [RecapPlayer]  -- ^ Состав команды+  } deriving (Eq,Show,Read,Generic)++instance FromJSON RecapTeam where+  parseJSON = genericParseJSON $ jsonOpts '_' 3+instance ToJSON RecapTeam where+  toJSON = genericToJSON $ jsonOpts '_' 3+  toEncoding = genericToEncoding $ jsonOpts '_' 3+ -- | Результаты команды по турам data TourResult = TourResult   { tor_tour :: Text            -- ^ Номер тура. __API NOTE__: должен быть Int@@ -564,12 +610,14 @@   :<|> "tournaments" :> Capture "idtournament" TournamentId :> "list" :> "town" :> Capture "idtown" Int :> Get '[JSON] [TournamentResult]   :<|> "tournaments" :> Capture "idtournament" TournamentId :> "list" :> "region" :> Capture "idregion" Int :> Get '[JSON] [TournamentResult]   :<|> "tournaments" :> Capture "idtournament" TournamentId :> "list" :> "country" :> Capture "idcountry" Int :> Get '[JSON] [TournamentResult]+  :<|> "tournaments" :> Capture "idtournament" TournamentId :> "recaps" :> Get '[JSON] [RecapTeam]   :<|> "tournaments" :> Capture "idtournament" TournamentId :> "recaps" :> Capture "idteam" TeamId :> Get '[JSON] [RecapPlayer] -- TODO: Set?   :<|> "tournaments" :> Capture "idtournament" TournamentId :> "results" :> Capture "idteam" TeamId :> Get '[JSON] [TourResult]   :<|> "tournaments" :> Capture "idtournament" TournamentId :> "controversials" :> Get '[JSON] [Controversial]   :<|> "tournaments" :> Capture "idtournament" TournamentId :> "appeals" :> Get '[JSON] [Appeal]   :<|> "teams" :> "search" :> QueryParam "name" Text :> QueryParam "town" Text :> QueryParam "region_name" Text :> QueryParam "country_name" Text :> QueryFlag "active_this_season" :> QueryParam "page" Int :> Get '[JSON] (Items Team)   :<|> "players" :> "search" :> QueryParam "surname" Text :> QueryParam "name" Text :> QueryParam "patronymic" Text :> QueryParam "page" Int :> Get '[JSON] (Items Player)+  :<|> "tournaments" :> "search" :> QueryParam "type_name" TournamentType :> QueryParam "archive" Int :> QueryParam "page" Int :> Get '[JSON] (Items TournamentShort)  -------------------------------------------------------------------------------- -- Non-API Types@@ -612,6 +660,36 @@   declareNamedSchema p = genericDeclareNamedSchema (schemaOpts 3) p     & mapped.schema.title ?~ "Request"     & mapped.schema.description ?~ "Заявка. В объекте содержатся поля accepted - статус заявки (null - не рассмотрена, false/true - отклонена или принята); town - город; representative-id - id представителя; representative-fullname - ФИО представителя, narrator-id - id ведущего (сейчас установлена в 0, сайт рейтинга не экспортирует id); narrator-fullname - ФИО ведущего; teams-count - примерное количество команд (заявлено); teams - список введённых команд"++-- | Синхрон, проводимый в городе+data SynchTown = SynchTown+  { stTournamentId :: TournamentId -- ^ Идентификатор турнира+  , stTournament :: Text           -- ^ Название турнира+  , stStatus :: ClaimStatus        -- ^ Статус заявки+  , stRepresentativeId :: PlayerId -- ^ Идентификатор представителя+  , stRepresentative :: Text       -- ^ ФИО представителя+  , stTime :: LocalTime            -- ^ Время проведения+  } deriving (Eq,Show,Read,Generic)++instance ToJSON SynchTown where+  toJSON = genericToJSON $ jsonOpts '-' 2+  toEncoding = genericToEncoding $ jsonOpts '-' 2++-- | Идентификатор города+type TownId = Int++-- | Город+data Town = Town+  { townId :: TownId            -- ^ Идентификатор города+  , townName :: Text            -- ^ Название города+  , townOtherName :: Maybe Text -- ^ Альтернативное название города (например, Бахмут - Артёмовск)+  , townRegion :: Maybe Text    -- ^ Регион+  , townCountry :: Maybe Text   -- ^ Страна+  } deriving (Eq,Show,Read,Generic)++instance ToJSON Town where+  toJSON = genericToJSON $ jsonOpts '-' 4+  toEncoding = genericToEncoding $ jsonOpts '-' 4  jsonOpts :: Char -> Int -> Options jsonOpts c k = defaultOptions { fieldLabelModifier = camelTo2 c . drop k }