{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE StrictData #-}
module RatingChgkInfo.NoApi
( requests
, synchTown
, towns
) where
import Prelude hiding (ByteString, get)
import RatingChgkInfo.Types
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
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
data CsvRequest = CsvRequest
{ crTown :: Text
, crRepresentative :: Text
, crNarrator :: Text
, crStatus :: Text
, crTeams :: Text
} deriving (Eq,Show,Read,Generic)
instance FromRecord CsvRequest
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
}
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 = []
}
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
, reqTown = ctTown cr
, reqRepresentativeId = fromMaybe 0 $ ctRepId cr
, reqRepresentativeFullname = T.concat
[ ctRepSurname cr
, " "
, ctRepName cr
, " "
, ctRepPatronym cr
]
, reqNarratorId = 0
, reqNarratorFullname = ""
, reqTeamsCount = 0
, 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 ';'
}
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
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 = ["января", "февраля", "марта", "апреля", "мая", "июня", "июля", "августа", "сентября", "октября", "ноября", "декабря"]
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"