diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,21 @@ +MIT License + +Copyright (c) 2021 Farbod Salamat-Zadeh + +Permission is hereby granted, free of charge, to any person obtaining a copy +of this software and associated documentation files (the "Software"), to deal +in the Software without restriction, including without limitation the rights +to use, copy, modify, merge, publish, distribute, sublicense, and/or sell +copies of the Software, and to permit persons to whom the Software is +furnished to do so, subject to the following conditions: + +The above copyright notice and this permission notice shall be included in all +copies or substantial portions of the Software. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE +AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER +LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, +OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE +SOFTWARE. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,48 @@ +# codeforces-cli + +Command line interface to interact with Codeforces. + +![demo](https://github.com/farbodsz/codeforces-cli/blob/master/docs/demo.gif?raw=true) + +## Features + +- View/filter contests and problems +- Watch contest standings and submissions +- Calculate rating after a virtual contest +- List rating changes for each contest +- And much more! + +## Installation + +The pre-compiled binary file can be found +[on the releases page](https://github.com/farbodsz/codeforces-cli/releases). + +Download it and place it in a directory in your `PATH`. For example, +`~/.local/bin/cf`. + +## Usage + +``` +Codeforces CLI v0.1.0 + +Usage: cf COMMAND + +Available options: + -h,--help Show this help text + +Available commands: + agenda Upcoming contests. Alias for contests --upcoming + contests List of contests + info Show the problems and your problem results of a + contest + friends List your friends (must be authenticated) + open Open a contest in the browser + problems View and filter problem sets + ratings Rating changes of a user + setup Setup your configuration file + standings Standings table of a contest + status Recent submissions of a user + user Information about a user + virtual Calculate your rating after a virtual contest, to + find what it would be if you competed live +``` diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/app/Main.hs b/app/Main.hs new file mode 100644 --- /dev/null +++ b/app/Main.hs @@ -0,0 +1,33 @@ +-------------------------------------------------------------------------------- + +module Main where + +import Codeforces.App + +-------------------------------------------------------------------------------- + +main :: IO () +main = do + command <- parseCommands + config <- loadConfig + + case command of + -- List/tabulate data + AgendaCmd -> contestList (ContestOpts False False True) + ContestsCmd opts -> contestList opts + InfoCmd cId opts -> contestInfo cId config opts + ProblemsCmd opts -> problemList opts + StandingsCmd cId opts -> standingsList cId config opts + + -- User-related commands + UserCmd h -> userInfo h + RatingsCmd h -> userRatings h + StatusCmd h opts -> userStatus h opts + FriendsCmd -> userFriends config + VirtualCmd cId h pts pen -> virtualRating cId h pts pen + + -- Miscellaneous + SetupCmd -> setupConfig + OpenCmd cId -> openContest cId + +-------------------------------------------------------------------------------- diff --git a/codeforces-cli.cabal b/codeforces-cli.cabal new file mode 100644 --- /dev/null +++ b/codeforces-cli.cabal @@ -0,0 +1,113 @@ +cabal-version: 1.12 +name: codeforces-cli +version: 0.1.0 +license: MIT +license-file: LICENSE +copyright: 2021 Farbod Salamat-Zadeh +maintainer: Farbod Salamat-Zadeh +author: Farbod Salamat-Zadeh +homepage: https://github.com/farbodsz/codeforces-cli#readme +bug-reports: https://github.com/farbodsz/codeforces-cli/issues +synopsis: Command line interface to interact with Codeforces. +description: + Please see the README on GitHub at + +category: CLI +build-type: Simple +extra-source-files: README.md + +source-repository head + type: git + location: https://github.com/farbodsz/codeforces-cli + +library + exposed-modules: + Codeforces.API + Codeforces.App + Codeforces.App.Commands + Codeforces.App.Commands.ContestCmds + Codeforces.App.Commands.ProblemsCmd + Codeforces.App.Commands.StandingsCmd + Codeforces.App.Commands.UserCmds + Codeforces.App.Commands.VirtualCmd + Codeforces.App.Config + Codeforces.App.Format + Codeforces.App.Options + Codeforces.App.Table + Codeforces.App.Watcher + Codeforces.Config + Codeforces.Error + Codeforces.Logging + Codeforces.Response + Codeforces.Types + Codeforces.Types.Common + Codeforces.Types.Contest + Codeforces.Types.Party + Codeforces.Types.Problem + Codeforces.Types.Rank + Codeforces.Types.RatingChange + Codeforces.Types.Standings + Codeforces.Types.Submission + Codeforces.Types.User + Codeforces.Virtual + Codeforces.Virtual.RatingCalculator + Codeforces.Virtual.Types + + hs-source-dirs: src + other-modules: Paths_codeforces_cli + default-language: Haskell2010 + default-extensions: + LambdaCase OverloadedStrings RecordWildCards ScopedTypeVariables + TupleSections + + ghc-options: -Wall + build-depends: + aeson >=1.5.6.0 && <1.6, + ansi-terminal >=0.10.3 && <0.11, + base >=4.7 && <5, + base16-bytestring >=0.1.1.7 && <0.2, + bytestring >=0.10.12.0 && <0.11, + containers >=0.6.2.1 && <0.7, + cryptohash-sha512 >=0.11.100.1 && <0.12, + directory >=1.3.6.0 && <1.4, + extra >=1.7.9 && <1.8, + http-client >=0.6.4.1 && <0.7, + http-conduit >=2.3.8 && <2.4, + http-types >=0.12.3 && <0.13, + open-browser >=0.2.1.0 && <0.3, + optparse-applicative >=0.15.1.0 && <0.16, + random ==1.1.*, + text >=1.2.4.1 && <1.3, + time >=1.9.3 && <1.10, + transformers >=0.5.6.2 && <0.6 + +executable cf + main-is: Main.hs + hs-source-dirs: app + other-modules: Paths_codeforces_cli + default-language: Haskell2010 + default-extensions: + LambdaCase OverloadedStrings RecordWildCards ScopedTypeVariables + TupleSections + + ghc-options: -threaded -rtsopts -with-rtsopts=-N -Wall + build-depends: + aeson >=1.5.6.0 && <1.6, + ansi-terminal >=0.10.3 && <0.11, + base >=4.7 && <5, + base16-bytestring >=0.1.1.7 && <0.2, + bytestring >=0.10.12.0 && <0.11, + codeforces-cli -any, + containers >=0.6.2.1 && <0.7, + cryptohash-sha512 >=0.11.100.1 && <0.12, + directory >=1.3.6.0 && <1.4, + extra >=1.7.9 && <1.8, + http-client >=0.6.4.1 && <0.7, + http-conduit >=2.3.8 && <2.4, + http-types >=0.12.3 && <0.13, + open-browser >=0.2.1.0 && <0.3, + optparse-applicative >=0.15.1.0 && <0.16, + random ==1.1.*, + text >=1.2.4.1 && <1.3, + time >=1.9.3 && <1.10, + transformers >=0.5.6.2 && <0.6 diff --git a/src/Codeforces/API.hs b/src/Codeforces/API.hs new file mode 100644 --- /dev/null +++ b/src/Codeforces/API.hs @@ -0,0 +1,257 @@ +-------------------------------------------------------------------------------- + +module Codeforces.API + ( module Codeforces.Types + , ResponseError(..) + , handleAPI + + -- * Contests + , getContests + , getContestStandings + , getContestStandings' + , StandingsParams(..) + + -- * Problems + , getAllProblemData + , getProblems + , getProblemStats + , getContestProblems + + -- * Ratings and ranks + , getContestRatingChanges + , getUserRatingHistory + + -- * Problem submissions + , getContestSubmissions + , getUserStatus + + -- * User details + , getUser + , getUsers + , getFriends + + -- * Virtual rating calculation + , calculateVirtualResult + , Delta + , Seed + , VirtualResult(..) + + -- * Configuration options + , UserConfig(..) + ) where + +import Codeforces.Config +import Codeforces.Error +import Codeforces.Response +import Codeforces.Types +import Codeforces.Virtual + +import Control.Arrow ( left ) +import Control.Monad.Trans.Except + +import qualified Data.ByteString.Char8 as BC +import qualified Data.Map as M +import qualified Data.Text as T +import qualified Data.Text.Encoding as T + +-------------------------------------------------------------------------------- + +handleAPI :: IO (Either ResponseError a) -> ExceptT CodeforcesError IO a +handleAPI m = ExceptT $ left ResponseError <$> m + +-------------------------------------------------------------------------------- + +-- | Query parameters for retrieving contest standings. +data StandingsParams = StandingsParams + { + -- | ID of the contest + paramContestId :: ContestId + -- | The starting index of the ranklist (1-based) + , paramFrom :: Maybe Int + -- | The number of standing rows to return + , paramRowCount :: Maybe Int + -- | If specified, only standings of this room are returned + , paramRoom :: Maybe Int + -- | If true, all participations are included. Otherwise only 'Contestant' + -- participations are included. + , paramUnofficial :: Bool + -- | If specified, the standings includes only these users. + , paramHandles :: Maybe [Handle] + } + deriving Show + +-------------------------------------------------------------------------------- + +-- | 'getContests' @isGym@ returns a list of contests that may or may not be gym +-- contests. +getContests :: Bool -> IO (Either ResponseError [Contest]) +getContests isGym = getData "/contest.list" [("gym", argBool isGym)] + +-- | 'getContestStandings' @standingsParams@ returns information about the +-- contest and a part of the standings list. +getContestStandings :: StandingsParams -> IO (Either ResponseError Standings) +getContestStandings StandingsParams {..} = getData + "/contest.standings" + [ ("contestId" , argContestId paramContestId) + , ("from" , argInt =<< paramFrom) + , ("count" , argInt =<< paramRowCount) + , ("room" , argInt =<< paramRoom) + , ("showUnofficial", argBool paramUnofficial) + , ("handles" , argHandles =<< paramHandles) + ] + +-- | Like 'getContestStandings' but returns the standings and the +-- 'RatingChange's for each user participating. +getContestStandings' + :: StandingsParams + -> IO (Either ResponseError (Standings, M.Map Handle RatingChange)) +getContestStandings' params = runExceptT $ do + ss <- ExceptT $ getContestStandings params + rcs <- ExceptT $ getContestRatingChanges (paramContestId params) + + let rcsMap = M.fromList $ map (rcHandle >>= (,)) rcs + + pure (ss, rcsMap) + +-- | 'getContestSubmissions' @contestId handle@ returns the submissions made by +-- the user in the contest given by @contestId@ +getContestSubmissions + :: ContestId -> Handle -> IO (Either ResponseError [Submission]) +getContestSubmissions cId h = getData + "/contest.status" + [("contestId", argContestId cId), ("handle", argHandle h)] + +-------------------------------------------------------------------------------- + +-- | 'getAllProblemData' @tags@ returns a 'ProblemsResponse' filtered by the +-- @tags@, if supplied. +getAllProblemData :: [ProblemTag] -> IO (Either ResponseError ProblemsResponse) +getAllProblemData ts = getData "/problemset.problems" [("tags", argTags ts)] + +-- | 'getProblems' @tags@ returns a list of 'Problem's containing the @tags@, if +-- provided. +getProblems :: [ProblemTag] -> IO (Either ResponseError [Problem]) +getProblems ts = fmap prProblems <$> getAllProblemData ts + +-- | Like 'getProblems' but returns a list of 'ProblemStats'. +getProblemStats :: [ProblemTag] -> IO (Either ResponseError [ProblemStats]) +getProblemStats ts = fmap prStats <$> getAllProblemData ts + +-- | 'getContestProblems' @contestId@ returns the list of problems for the given +-- contest. +-- +-- This should be used instead of filtering results from 'getProblems' for two +-- main reasons: +-- +-- (1) 'problemContestId' can only refer to one contest, so problems +-- appearing in multiple contests may not be filtered correctly. +-- (2) 'getProblems' returns larger output potentially affecting performance +-- +getContestProblems :: ContestId -> IO (Either ResponseError [Problem]) +getContestProblems cId = fmap standingsProblems <$> getContestStandings + StandingsParams { paramContestId = cId + , paramFrom = Just 1 + , paramRowCount = Just 1 + , paramRoom = Nothing + , paramUnofficial = False + , paramHandles = Nothing + } + +-------------------------------------------------------------------------------- + +-- | 'getContestRatingChanges' @contestId@ returns a list of 'RatingChange's +-- for the contest. +getContestRatingChanges + :: ContestId -> IO (Either ResponseError [RatingChange]) +getContestRatingChanges cId = + getData "/contest.ratingChanges" [("contestId", argContestId cId)] + +-- | 'getUserRatingHistory' @handle@ returns a list of 'RatingChange's for the +-- requested user +getUserRatingHistory :: Handle -> IO (Either ResponseError [RatingChange]) +getUserRatingHistory h = getData "/user.rating" [("handle", argHandle h)] + +-------------------------------------------------------------------------------- + +-- | 'getUser' @handle@ returns the 'User' with the given @handle@ +getUser :: Handle -> IO (Either ResponseError User) +getUser h = fmap head <$> getUsers [h] + +-- | 'getUsers' @handles@ returns a list of 'User's with the given @handles@ +getUsers :: [Handle] -> IO (Either ResponseError [User]) +getUsers [] = pure $ Right [] +getUsers hs = getData "/user.info" [("handles", argHandles hs)] + +-- 'getFriends' @config@ returns the handles of the friends of the currently +-- authenticated user. +getFriends :: UserConfig -> IO (Either ResponseError [Handle]) +getFriends cfg = getAuthorizedData cfg "/user.friends" [] + +-- | 'getUserStatus' @handle from count@ returns the @count@ most recent +-- submissions by the user, starting from the @from@-th one. +getUserStatus :: Handle -> Int -> Int -> IO (Either ResponseError [Submission]) +getUserStatus h f n = getData + "/user.status" + [("handle", argHandle h), ("from", argInt f), ("count", argInt n)] + +-------------------------------------------------------------------------------- + +-- | 'calculateVirtualResult' @contestId handle points penalty@ computes the +-- rating change the user would gain had they competed in the contest live, and +-- their expected ranking for the contest. +-- +calculateVirtualResult + :: ContestId + -> Handle + -> Points + -> Int + -> IO (Either ResponseError (User, Maybe VirtualResult)) +calculateVirtualResult cId handle points penalty = runExceptT $ do + rcs <- ExceptT $ getContestRatingChanges cId + + standings <- ExceptT $ getContestStandings $ StandingsParams + { paramContestId = cId + , paramFrom = Nothing + , paramRowCount = Nothing + , paramRoom = Nothing + , paramUnofficial = False + , paramHandles = Nothing + } + + user <- ExceptT $ getUser handle + let vUser = VirtualUser { vuPoints = points + , vuPenalty = penalty + , vuRating = userRating user + } + result = calculateResult vUser rcs (standingsRanklist standings) + + pure (user, result) + +-------------------------------------------------------------------------------- + +argBool :: Bool -> Maybe BC.ByteString +argBool = Just . BC.pack . show + +argText :: T.Text -> Maybe BC.ByteString +argText = Just . T.encodeUtf8 + +argTexts :: [T.Text] -> Maybe BC.ByteString +argTexts xs | null xs = Nothing + | otherwise = (Just . T.encodeUtf8 . T.intercalate ";") xs + +argInt :: Int -> Maybe BC.ByteString +argInt = Just . BC.pack . show + +argContestId :: ContestId -> Maybe BC.ByteString +argContestId = argInt . unContestId + +argHandle :: Handle -> Maybe BC.ByteString +argHandle = argText . unHandle + +argHandles :: [Handle] -> Maybe BC.ByteString +argHandles = argTexts . map unHandle + +argTags :: [ProblemTag] -> Maybe BC.ByteString +argTags = argTexts + +-------------------------------------------------------------------------------- diff --git a/src/Codeforces/App.hs b/src/Codeforces/App.hs new file mode 100644 --- /dev/null +++ b/src/Codeforces/App.hs @@ -0,0 +1,13 @@ +-------------------------------------------------------------------------------- + +module Codeforces.App + ( module Codeforces.App.Commands + , module Codeforces.App.Config + , module Codeforces.App.Options + ) where + +import Codeforces.App.Commands +import Codeforces.App.Config +import Codeforces.App.Options + +-------------------------------------------------------------------------------- diff --git a/src/Codeforces/App/Commands.hs b/src/Codeforces/App/Commands.hs new file mode 100644 --- /dev/null +++ b/src/Codeforces/App/Commands.hs @@ -0,0 +1,17 @@ +-------------------------------------------------------------------------------- + +module Codeforces.App.Commands + ( module Codeforces.App.Commands.ContestCmds + , module Codeforces.App.Commands.ProblemsCmd + , module Codeforces.App.Commands.StandingsCmd + , module Codeforces.App.Commands.UserCmds + , module Codeforces.App.Commands.VirtualCmd + ) where + +import Codeforces.App.Commands.ContestCmds +import Codeforces.App.Commands.ProblemsCmd +import Codeforces.App.Commands.StandingsCmd +import Codeforces.App.Commands.UserCmds +import Codeforces.App.Commands.VirtualCmd + +-------------------------------------------------------------------------------- diff --git a/src/Codeforces/App/Commands/ContestCmds.hs b/src/Codeforces/App/Commands/ContestCmds.hs new file mode 100644 --- /dev/null +++ b/src/Codeforces/App/Commands/ContestCmds.hs @@ -0,0 +1,148 @@ +-------------------------------------------------------------------------------- + +-- | Contest-related commands. +module Codeforces.App.Commands.ContestCmds + ( contestList + , contestInfo + , openContest + ) where + +import Codeforces.API +import Codeforces.App.Format +import Codeforces.App.Options +import Codeforces.App.Table +import Codeforces.App.Watcher +import Codeforces.Error + +import Control.Monad.Trans.Class +import Control.Monad.Trans.Except + +import qualified Data.Map as M +import Data.Maybe +import Data.Text ( Text ) +import qualified Data.Text as T +import qualified Data.Text.IO as T +import Data.Time + +import Web.Browser + +-------------------------------------------------------------------------------- + +contestList :: ContestOpts -> IO () +contestList ContestOpts {..} = handleE $ runExceptT $ do + contests <- handleAPI $ getContests optIsGym + now <- lift getCurrentTime + + let headers = [("#", 4), ("Name", 50), ("Date", 16), ("Duration", 10)] + rows = map + (\Contest {..} -> + plainCell + <$> [ showText $ unContestId contestId + , contestName + , fmtStartTime contestStartTime + , fmtDuration contestDuration + ] + ) + (filterContests optIsPast optIsUpcoming now contests) + + lift $ mapM_ T.putStrLn $ makeTable headers rows + +-- | 'filterContests' @onlyPast onlyUpcoming currentTime@ filters and orders a +-- list of contests depending on whether past or upcoming (or both/all) contests +-- should be shown. +filterContests :: Bool -> Bool -> UTCTime -> [Contest] -> [Contest] +filterContests False False _ = id +filterContests False True now = reverse . filter (not . isContestPast now) +filterContests True False now = filter (isContestPast now) +filterContests True True _ = id + +-- | Whether the contest is in the past relative to the given time. +isContestPast :: UTCTime -> Contest -> Bool +isContestPast now c = maybe False (< now) (contestStartTime c) + +fmtStartTime :: Maybe UTCTime -> Text +fmtStartTime = + maybe "" (T.pack . formatTime defaultTimeLocale "%H:%M %d-%b-%y") + +fmtDuration :: DiffTime -> Text +fmtDuration = T.pack . formatTime defaultTimeLocale "%h:%0M hrs" + +-------------------------------------------------------------------------------- + +contestInfo :: ContestId -> UserConfig -> InfoOpts -> IO () +contestInfo cId cfg opts = + handleWatch (optInfoWatch opts) (contestInfoTable cId cfg opts) + +-- | 'contestInfoTable' @problems submissions statistics@ fetches data about the +-- contest and constructs a table of its problems. +-- +-- The table includes problem statistics, and if the user has made a submission, +-- their submission verdict for the problem. +-- +contestInfoTable + :: ContestId -> UserConfig -> InfoOpts -> IO (Either CodeforcesError Table) +contestInfoTable cId cfg opts = runExceptT $ do + let handle = fromMaybe (cfgHandle cfg) (optHandle opts) + + ps <- handleAPI $ getContestProblems cId + statMap <- handleAPI $ fmap problemStatsMap <$> getProblemStats [] + subMap <- + handleAPI $ fmap submissionsMap <$> getContestSubmissions cId handle + + let headers = + [ ("#" , 2) + , ("Problem", 30) + , ("Verdict", 35) + , ("Time" , 7) + , ("Memory" , 8) + , ("Solved" , 7) + ] + rows = map + (\Problem {..} -> + let mSub = M.lookup problemIndex subMap + mStats = M.lookup problemIndex statMap + in [ plainCell problemIndex + , plainCell problemName + , contestSubmissionCell mSub + , plainCell $ maybeTimeTaken mSub + , plainCell $ maybeMemTaken mSub + , plainCell $ maybeSolved mStats + ] + ) + ps + + pure $ makeTable headers rows + where + maybeTimeTaken = maybe "-" (fmtTimeConsumed . submissionTimeConsumed) + maybeMemTaken = maybe "-" (fmtMemoryConsumed . submissionMemoryConsumed) + maybeSolved = maybe "" (("x" <>) . showText . pStatSolvedCount) + +-- | Shows the verdict of a contest submission. +contestSubmissionCell :: Maybe Submission -> Cell +contestSubmissionCell Nothing = plainCell "-" +contestSubmissionCell (Just Submission {..}) = verdictCell + submissionTestset + submissionPassedTestCount + submissionPoints + submissionVerdict + +-- | 'problemStatsMap' @stats@ computes a map of each problem's index to the +-- corresponding 'ProblemStats' for it. +problemStatsMap :: [ProblemStats] -> M.Map ProblemIndex ProblemStats +problemStatsMap = M.fromList . map (pStatProblemIndex >>= (,)) + +-- | 'submissionsMap' @submissions@ computes a map of each problem's index to +-- the most recent submission for it. +submissionsMap :: [Submission] -> M.Map ProblemIndex Submission +submissionsMap = + M.fromListWith (const id) . map (problemIndex . submissionProblem >>= (,)) + +-------------------------------------------------------------------------------- + +-- | 'openContest' @contestId@ opens the URL to the specified contest in the +-- user's preferred web browser. +openContest :: ContestId -> IO () +openContest cId = + openBrowser ("https://codeforces.com/contest/" <> show cId) >> pure () + +-------------------------------------------------------------------------------- diff --git a/src/Codeforces/App/Commands/ProblemsCmd.hs b/src/Codeforces/App/Commands/ProblemsCmd.hs new file mode 100644 --- /dev/null +++ b/src/Codeforces/App/Commands/ProblemsCmd.hs @@ -0,0 +1,48 @@ +-------------------------------------------------------------------------------- + +-- | Problems command. +module Codeforces.App.Commands.ProblemsCmd + ( problemList + ) where + +import Codeforces.API +import Codeforces.App.Format +import Codeforces.App.Options +import Codeforces.App.Table +import Codeforces.Error + +import Control.Monad.Trans.Class +import Control.Monad.Trans.Except + +import Data.Text ( Text ) +import qualified Data.Text.IO as T + +-------------------------------------------------------------------------------- + +problemList :: ProblemOpts -> IO () +problemList ProblemOpts {..} = handleE $ runExceptT $ do + let ratingBounds = inRatingRange (optMinRating, optMaxRating) + + problems <- handleAPI $ fmap (filter ratingBounds) <$> getProblems [] + + let headers = [("#", 6), ("Name", 40), ("Rating", 6)] + rows = map + (\Problem {..} -> + [ plainCell $ fmtProblemIndex problemContestId problemIndex + , plainCell problemName + , maybe blankCell ratingCell problemRating + ] + ) + problems + + lift $ mapM_ T.putStrLn $ makeTable headers rows + +fmtProblemIndex :: Maybe ContestId -> ProblemIndex -> Text +fmtProblemIndex cId pIdx = maybe "" (showText . unContestId) cId <> pIdx + +inRatingRange :: (Rating, Rating) -> Problem -> Bool +inRatingRange (minr, maxr) p = case problemRating p of + Nothing -> False + Just r -> minr <= r && r <= maxr + +-------------------------------------------------------------------------------- diff --git a/src/Codeforces/App/Commands/StandingsCmd.hs b/src/Codeforces/App/Commands/StandingsCmd.hs new file mode 100644 --- /dev/null +++ b/src/Codeforces/App/Commands/StandingsCmd.hs @@ -0,0 +1,126 @@ +-------------------------------------------------------------------------------- + +-- | Standings command. +module Codeforces.App.Commands.StandingsCmd + ( standingsList + ) where + +import Codeforces.API hiding ( RankColor(..) ) +import Codeforces.App.Format +import Codeforces.App.Options +import Codeforces.App.Table +import Codeforces.App.Watcher +import Codeforces.Error + +import Control.Monad.Trans.Except + +import qualified Data.Map as M +import Data.Text ( Text ) +import qualified Data.Text as T + +import System.Console.ANSI.Types + +-------------------------------------------------------------------------------- + +standingsList :: ContestId -> UserConfig -> StandingOpts -> IO () +standingsList cId cfg StandingOpts {..} = + handleWatch optStandWatch $ runExceptT $ do + friends <- handleAPI $ getFriends cfg + + let mHs = if optFriends + then Just (cfgHandle cfg : friends) + else Nothing + + (standings, rcs) <- handleAPI $ getContestStandings' StandingsParams + { paramContestId = cId + , paramFrom = Just optFromIndex + , paramRowCount = Just optRowCount + , paramRoom = optRoom + , paramUnofficial = optShowUnofficial + , paramHandles = mHs + } + + if null (standingsRanklist standings) + then + throwE + (if optFriends + then StandingsWithFriendsEmpty + else StandingsEmpty + ) + else pure $ standingsTable standings rcs + +standingsTable :: Standings -> M.Map Handle RatingChange -> Table +standingsTable s rcs = makeTable headers rows + where + headers = [("#", 5), ("Who", 20), ("=", totalPointsColW), ("*", 5)] + ++ map (\p -> (problemIndex p, problemColW)) (standingsProblems s) + rows = map + (\RanklistRow {..} -> + [ plainCell $ showText rrRank + , partyCell rrParty rcs + , totalPointsCell rrPoints + , plainCell $ showText rrPenalty + ] + ++ map (problemResultCell scoringType) rrProblemResults + ) + (standingsRanklist s) + + scoringType = contestType $ standingsContest s + + -- Final score in ICPC contest is number of problems solved (single digit) + totalPointsColW = if scoringType == ScoringICPC then 2 else 5 + -- Problem score in ICPC contest is only 2-3 chars wide (e.g. "+5", "-2") + problemColW = if scoringType == ScoringICPC then 3 else 5 + +partyCell :: Party -> M.Map Handle RatingChange -> Cell +partyCell Party {..} rcs = case partyMembers of + [Member {..}] -> case M.lookup memberHandle rcs of + Nothing -> plainCell $ participant $ unHandle memberHandle + Just rc -> + coloredCell (userColor rc) (participant $ unHandle memberHandle) + + ms -> case partyTeamName of + Nothing -> plainCell $ participant $ memberList ms + Just teamName -> plainCell $ participant teamName + where + participant = fmtParticipation partyParticipantType + memberList = T.intercalate "," . map (unHandle . memberHandle) + userColor = convertRankColor . rankColor . getRank . rcOldRating + +-- | 'fmtParticipation' @participantType text@ returns the @text@ with either a +-- prefix/suffix/no changes, to indicate the type of contest participation. +fmtParticipation :: ParticipantType -> Text -> Text +fmtParticipation Virtual t = t <> " #" +fmtParticipation Contestant t = t +fmtParticipation _ t = "* " <> t + +-- | 'showPoints' @points@ returns a textual representation of the points type. +-- If @points@ is an integer (e.g. @42.0@) then the integer without decimals +-- is returned (@42@), otherwise the decimals are shown. +showPoints :: Points -> Text +showPoints x = if x == fromInteger r then showText r else showText x + where r = round x + +-- | Cell showing the total points obtained by a user in the contest. +totalPointsCell :: Points -> Cell +totalPointsCell = plainCell . showPoints + +-- | Cell showing the points obtained for a problem submission. +problemResultCell :: ScoringType -> ProblemResult -> Cell +problemResultCell st pr@ProblemResult {..} = if prNotAttempted pr + then blankCell + else case st of + ScoringCF -> if prPoints == 0 + then coloredCell Red $ "-" <> showText prRejectedAttemptCount + else coloredCell Green $ showPoints prPoints + ScoringICPC -> if prPoints == 0 + then coloredCell Blue $ "-" <> showText prRejectedAttemptCount + else coloredCell Green $ if prRejectedAttemptCount == 0 + then "+" + else "+" <> showText prRejectedAttemptCount + ScoringIOI -> case prPoints of + 0 -> blankCell + 100 -> coloredCell Green "100" + x -> plainCell (showPoints x) + +-------------------------------------------------------------------------------- diff --git a/src/Codeforces/App/Commands/UserCmds.hs b/src/Codeforces/App/Commands/UserCmds.hs new file mode 100644 --- /dev/null +++ b/src/Codeforces/App/Commands/UserCmds.hs @@ -0,0 +1,145 @@ +-------------------------------------------------------------------------------- + +-- | User-related commands. +module Codeforces.App.Commands.UserCmds + ( userInfo + , userRatings + , userStatus + , userFriends + ) where + +import Codeforces.API +import Codeforces.App.Format +import Codeforces.App.Options +import Codeforces.App.Table +import Codeforces.App.Watcher +import Codeforces.Error + +import Control.Monad.Extra +import Control.Monad.Trans.Class +import Control.Monad.Trans.Except + +import Data.Text ( Text ) +import qualified Data.Text as T +import qualified Data.Text.IO as T +import Data.Time + +-------------------------------------------------------------------------------- + +userInfo :: Handle -> IO () +userInfo h = handleE $ runExceptT $ do + u <- handleAPI $ getUser h + + let rank = getRank (userRating u) + + lift $ do + putStrLn "" + T.putStrLn $ rankColored (rankColor rank) $ T.concat + [indent, rankName rank, " ", unHandle $ userHandle u] + whenJust (sequenceA [userFirstName u, userLastName u]) + $ \ns -> T.putStrLn $ indent <> T.unwords ns + + printRatings u + printPlace u + putStrLn "" + +printRatings :: User -> IO () +printRatings User {..} = do + putStrLn "" + T.putStrLn $ T.concat + [ indent + , "Rating: " + , rankColored (rankColor (getRank userRating)) (showText userRating) + ] + let maxRank = getRank userRating + T.putStrLn $ T.concat + [ indent + , " (max: " + , rankColored + (rankColor maxRank) + (T.concat [rankName maxRank, ", ", showText userMaxRating]) + , ")" + ] + +printPlace :: User -> IO () +printPlace User {..} = do + whenJust (sequenceA [userCity, userCountry]) $ \xs -> + T.putStrLn $ indent <> "City: " <> T.intercalate ", " xs + whenJust userOrganization + $ \o -> T.putStrLn $ indent <> "Organisation: " <> o + +-------------------------------------------------------------------------------- + +userRatings :: Handle -> IO () +userRatings h = handleE $ runExceptT $ do + rcs <- handleAPI $ getUserRatingHistory h + + let headers = + [ ("#" , 3) + , ("Contest", 50) + , ("Rank" , 5) + , ("Change" , 6) + , ("Rating" , 6) + ] + rows = reverse $ zipWith + (\RatingChange {..} num -> + [ plainCell $ showText num + , plainCell rcContestName + , plainCell $ showText rcRank + , differenceCell (rcNewRating - rcOldRating) + , ratingCell rcNewRating + ] + ) + rcs + ([1 ..] :: [Int]) + + lift $ mapM_ T.putStrLn $ makeTable headers rows + +-------------------------------------------------------------------------------- + +userStatus :: Handle -> StatusOpts -> IO () +userStatus h opts = handleWatch (optStatusWatch opts) (userStatusTable h opts) + +userStatusTable :: Handle -> StatusOpts -> IO (Either CodeforcesError Table) +userStatusTable h StatusOpts {..} = runExceptT $ do + ss <- handleAPI $ getUserStatus h optStatusFrom optStatusCount + + let headers = + [ ("When" , 12) + , ("Problem", 35) + , ("Lang" , 11) + , ("Verdict", 35) + , ("Time" , 7) + , ("Memory" , 8) + ] + rows = map + (\Submission {..} -> + [ plainCell $ fmtTime submissionTime + , plainCell $ fmtProblem submissionProblem + , plainCell submissionProgrammingLanguage + , verdictCell submissionTestset + submissionPassedTestCount + submissionPoints + submissionVerdict + , plainCell $ fmtTimeConsumed submissionTimeConsumed + , plainCell $ fmtMemoryConsumed submissionMemoryConsumed + ] + ) + ss + + pure $ makeTable headers rows + +fmtTime :: UTCTime -> Text +fmtTime = T.pack . formatTime defaultTimeLocale "%b/%d %H:%M" + +fmtProblem :: Problem -> Text +fmtProblem p = T.concat [problemIndex p, " - ", problemName p] + +-------------------------------------------------------------------------------- + +userFriends :: UserConfig -> IO () +userFriends cfg = handleE $ runExceptT $ do + fs <- handleAPI $ getFriends cfg + lift $ mapM_ (T.putStrLn . unHandle) fs + +-------------------------------------------------------------------------------- diff --git a/src/Codeforces/App/Commands/VirtualCmd.hs b/src/Codeforces/App/Commands/VirtualCmd.hs new file mode 100644 --- /dev/null +++ b/src/Codeforces/App/Commands/VirtualCmd.hs @@ -0,0 +1,70 @@ +-------------------------------------------------------------------------------- + +-- | Virtual contest/rating command. +module Codeforces.App.Commands.VirtualCmd + ( virtualRating + ) where + +import Codeforces.API +import Codeforces.App.Format +import Codeforces.Error + +import Control.Monad.Trans.Class +import Control.Monad.Trans.Except + +import qualified Data.Text as T +import qualified Data.Text.IO as T + +-------------------------------------------------------------------------------- + +virtualRating :: ContestId -> Handle -> Points -> Int -> IO () +virtualRating cId h pts pen = handleE $ runExceptT $ do + (u, mRes) <- handleAPI $ calculateVirtualResult cId h pts pen + + case mRes of + Nothing -> throwE VirtualNoResult + Just res -> lift $ printVirtualRes u res + +printVirtualRes :: User -> VirtualResult -> IO () +printVirtualRes u VirtualResult {..} = do + printRankings virtualSeed virtualRank + + putStrLn "" + putStrLn "Rating change:" + + let currRating = userRating u + let currRank = getRank currRating + let newRating = currRating + virtualDelta + let newRank = getRank newRating + + putStrLn $ concat [" (", show currRating, " -> ", show newRating, ")"] + putStrLn "" + + T.putStrLn $ T.concat [" ", indent, diffColored virtualDelta] + putStrLn "" + + let handle = unHandle (userHandle u) + desc = if currRank == newRank + then T.concat + [ "Would remain " + , rankName currRank + , " " + , rankColored (rankColor currRank) handle + ] + else T.concat + [ "Would become " + , rankName newRank + , ": " + , rankColored (rankColor currRank) handle + , " -> " + , rankColored (rankColor newRank) handle + ] + T.putStrLn $ T.concat [" ", desc, "\n"] + +printRankings :: Seed -> Int -> IO () +printRankings seed rank = do + putStrLn "" + putStrLn $ "Expected ranking: " ++ show (round seed :: Int) + putStrLn $ "Actual ranking: " ++ show rank + +------------------------------------------------------------------------------- diff --git a/src/Codeforces/App/Config.hs b/src/Codeforces/App/Config.hs new file mode 100644 --- /dev/null +++ b/src/Codeforces/App/Config.hs @@ -0,0 +1,91 @@ +-------------------------------------------------------------------------------- + +module Codeforces.App.Config + ( loadConfig + , setupConfig + ) where + +import Codeforces.Config +import Codeforces.Types + +import Data.Aeson +import qualified Data.ByteString.Lazy as BL +import Data.Maybe +import qualified Data.Text.IO as T + +import System.Directory +import System.IO + +-------------------------------------------------------------------------------- + +-- | 'loadConfig' returns the user configuration instance from the config file. +loadConfig :: IO UserConfig +loadConfig = do + path <- configPath + hasConfig <- doesPathExist path + mConfig <- if hasConfig then decode <$> BL.readFile path else pure Nothing + pure $ fromMaybe emptyConfig mConfig + +-- | The user configuration file path is +-- @configPath/codeforces-cli/config.json@ where @configPath@ is the user's +-- 'XdgConfig' directory. +configPath :: IO FilePath +configPath = getXdgDirectory XdgConfig "codeforces-cli/config.json" + +emptyConfig :: UserConfig +emptyConfig = UserConfig { cfgHandle = Handle "", cfgKey = "", cfgSecret = "" } + +-------------------------------------------------------------------------------- + +-- | Creates a configuration file with user prompts. +-- +-- The user must decide whether to overwrite their configuration file if one +-- already exists. +-- +setupConfig :: IO () +setupConfig = do + hSetBuffering stdin LineBuffering + hSetBuffering stdout NoBuffering + + path <- configPath + exists <- doesPathExist path + + continue <- if exists + then do + putStrLn + $ "Warning: A configuration file already exists in " + ++ path + putStr "Do you want to continue? [Y/n]: " + resp <- getLine + pure $ resp == "Y" + else pure True + + if not continue then pure () else createConfig path + +-- | 'createConfig' is an interactive prompt tool to help users create +-- configuration files easily. +createConfig :: FilePath -> IO () +createConfig path = do + putStrLn "" + putStrLn + "You'll need to generate an API key via \ + \\n" + putStrLn "Then, complete the following details:\n" + + putStr "Codeforces handle: " + handle <- T.getLine + + putStr "API key: " + key <- T.getLine + + putStr "API secret: " + secret <- T.getLine + + BL.writeFile path $ encode UserConfig { cfgHandle = Handle handle + , cfgKey = key + , cfgSecret = secret + } + putStrLn "" + putStrLn $ "Successfully created a configuration file in " ++ path + +-------------------------------------------------------------------------------- diff --git a/src/Codeforces/App/Format.hs b/src/Codeforces/App/Format.hs new file mode 100644 --- /dev/null +++ b/src/Codeforces/App/Format.hs @@ -0,0 +1,135 @@ +-------------------------------------------------------------------------------- + +-- | Utility functions for formatting data. +module Codeforces.App.Format where + +import Codeforces.Types hiding ( RankColor(..) ) +import qualified Codeforces.Types.Rank as R + +import Codeforces.App.Table + +import Data.Fixed +import Data.Text ( Text ) +import qualified Data.Text as T +import Data.Time + +import System.Console.ANSI + +-------------------------------------------------------------------------------- + +-- | 'showText' @x@ is a 'Data.Text' version of 'show' +showText :: Show a => a -> Text +showText = T.pack . show + +-- | 'colored' @color text@ wraps some text around SGR codes to display it in +-- the given color. +colored :: Color -> Text -> Text +colored c s = T.concat + [ T.pack $ setSGRCode [SetColor Foreground Dull c] + , s + , T.pack $ setSGRCode [Reset] + ] + +rankColored :: R.RankColor -> Text -> Text +rankColored = colored . convertRankColor + +convertRankColor :: R.RankColor -> Color +convertRankColor R.Gray = White +convertRankColor R.Green = Green +convertRankColor R.Cyan = Cyan +convertRankColor R.Blue = Blue +convertRankColor R.Violet = Magenta +convertRankColor R.Orange = Yellow +convertRankColor R.Red = Red + +-- | Like 'differenceCell' but returns a 'Text' rather than a 'Cell'. +diffColored :: Int -> Text +diffColored x | x > 0 = colored Green $ "+" <> showText x + | x == 0 = " " <> showText x + | otherwise = colored Red $ showText x + +indent :: Text +indent = T.replicate 6 " " + +-------------------------------------------------------------------------------- + +fmtTimeConsumed :: Int -> Text +fmtTimeConsumed x = showText x <> " ms" + +fmtMemoryConsumed :: Int -> Text +fmtMemoryConsumed x = showText (x `div` 1000) <> " KB" + +-- | Returns an approximate and human-friendly time difference. +-- +-- Possible options are: +-- * "just now" +-- * "5 seconds ago" +-- * "X seconds ago" where X is a multiple of 10 +-- * "X minutes ago" +-- +fmtDiffTime :: NominalDiffTime -> Text +fmtDiffTime diff = go (nominalDiffTimeToSeconds diff) + where + go x | x < 5 = "just now" + | x < 10 = "5 seconds ago" + | x < 60 = showText (x `div'` 10 :: Int) <> "0 seconds ago" + | otherwise = showText (x `div'` 60 :: Int) <> " minutes ago" + +-------------------------------------------------------------------------------- + +plainCell :: Text -> Cell +plainCell = Cell [Reset] + +coloredCell :: Color -> Text -> Cell +coloredCell c = Cell [SetColor Foreground Dull c] + +blankCell :: Cell +blankCell = plainCell "" + +ratingCell :: Rating -> Cell +ratingCell x = + let color = convertRankColor $ rankColor $ getRank x + in coloredCell color (showText x) + +-- | 'differenceCell' @diff@ colors a number red, white or green, depending on +-- whether it's negative, 0, or positive. +differenceCell :: Int -> Cell +differenceCell x | x > 0 = coloredCell Green $ "+" <> showText x + | x == 0 = plainCell $ " " <> showText x + | otherwise = coloredCell Red $ showText x + +-- | 'verdictCell' @testset passedTestCount points verdict@ returns a cell +-- displaying the status of a submission, such as "Accepted" or "Wrong answer on +-- pretest 2". +verdictCell :: Testset -> Int -> Maybe Points -> Maybe Verdict -> Cell +verdictCell _ _ _ Nothing = plainCell "In queue" +verdictCell testset passed points (Just v) = case v of + Ok -> case testset of + Tests -> coloredCell Green "Accepted" + Samples -> coloredCell Green "Samples passed" + Pretests -> coloredCell Green "Pretests passed" + Challenges -> coloredCell Green "Challenges passed" + Partial -> coloredCell Yellow $ maybe + "Partial result" + (\pts -> T.concat ["Partial result: ", showText pts, " points"]) + points + Challenged -> coloredCell Red "Hacked" + CompilationError -> plainCell $ verdictText v + Skipped -> plainCell $ verdictText v + SecurityViolated -> plainCell $ verdictText v + Crashed -> plainCell $ verdictText v + InputPreparationCrashed -> plainCell $ verdictText v + Rejected -> plainCell $ verdictText v + _ -> + let currTest = passed + 1 + clr = if v == Testing then White else Blue + text = T.concat + [ verdictText v + , " on " + , T.toLower . T.init $ showText testset + , " " + , showText currTest + ] + in coloredCell clr text + +-------------------------------------------------------------------------------- diff --git a/src/Codeforces/App/Options.hs b/src/Codeforces/App/Options.hs new file mode 100644 --- /dev/null +++ b/src/Codeforces/App/Options.hs @@ -0,0 +1,306 @@ +-------------------------------------------------------------------------------- + +module Codeforces.App.Options + ( Command(..) + , ContestOpts(..) + , InfoOpts(..) + , ProblemOpts(..) + , StandingOpts(..) + , StatusOpts(..) + , parseCommands + ) where + +import Codeforces.Types +import Paths_codeforces_cli ( version ) + +import Data.Version ( showVersion ) + +import Options.Applicative + +-------------------------------------------------------------------------------- + +data Command + = AgendaCmd + | ContestsCmd ContestOpts + | FriendsCmd + | InfoCmd ContestId InfoOpts + | OpenCmd ContestId + | ProblemsCmd ProblemOpts + | RatingsCmd Handle + | SetupCmd + | StandingsCmd ContestId StandingOpts + | StatusCmd Handle StatusOpts + | UserCmd Handle + | VirtualCmd ContestId Handle Points Int + deriving Eq + +data ContestOpts = ContestOpts + { optIsGym :: Bool + , optIsPast :: Bool + , optIsUpcoming :: Bool + } + deriving Eq + +data InfoOpts = InfoOpts + { optHandle :: Maybe Handle + , optInfoWatch :: Bool + } + deriving Eq + +data ProblemOpts = ProblemOpts + { optMinRating :: Rating + , optMaxRating :: Rating + } + deriving Eq + +data StandingOpts = StandingOpts + { optShowUnofficial :: Bool + , optFromIndex :: Int + , optRowCount :: Int + , optRoom :: Maybe Int + , optFriends :: Bool + , optStandWatch :: Bool + } + deriving Eq + +data StatusOpts = StatusOpts + { optStatusFrom :: Int + , optStatusCount :: Int + , optStatusWatch :: Bool + } + deriving Eq + +-------------------------------------------------------------------------------- + +parseCommands :: IO Command +parseCommands = execParser opts + +opts :: ParserInfo Command +opts = info (commandP <**> helper) (appHeader <> fullDesc) + +-- | CLI name and version number. +appHeader :: InfoMod Command +appHeader = header $ "Codeforces CLI v" ++ appVersion + +-- | Version number of the CLI. +appVersion :: String +appVersion = showVersion version + +-------------------------------------------------------------------------------- + +commandP :: Parser Command +commandP = + hsubparser + $ command + "agenda" + (info + agendaP + (progDesc "Upcoming contests. Alias for contests --upcoming") + ) + <> command "contests" (info contestsP (progDesc "List of contests")) + <> command + "info" + (info + contestInfoP + (progDesc + "Show the problems and your problem results of a contest" + ) + ) + <> command + "friends" + (info friendsP + (progDesc "List your friends (must be authenticated)") + ) + <> command "open" + (info openP (progDesc "Open a contest in the browser")) + <> command + "problems" + (info problemsP (progDesc "View and filter problem sets")) + <> command "ratings" + (info ratingsP (progDesc "Rating changes of a user")) + <> command "setup" + (info setupP (progDesc "Setup your configuration file")) + <> command + "standings" + (info standingsP (progDesc "Standings table of a contest")) + <> command "status" + (info statusP (progDesc "Recent submissions of a user")) + <> command "user" (info userP (progDesc "Information about a user")) + <> command + "virtual" + (info + virtualP + (progDesc + "Calculate your rating after a virtual contest,\ + \ to find what it would be if you competed live" + ) + ) + +agendaP :: Parser Command +agendaP = pure AgendaCmd + +contestsP :: Parser Command +contestsP = + fmap ContestsCmd + $ ContestOpts + <$> switch + ( long "gym" + <> short 'g' + <> help + "If true then gym contests are returned,\ + \ otherwise, just regular contests are shown." + ) + <*> switch (long "past" <> short 'p' <> help "Show only past contests.") + <*> switch + ( long "upcoming" + <> short 'u' + <> help + "Show only upcoming contests.\ + \ This can also be done with the `agenda` command." + ) + + +contestInfoP :: Parser Command +contestInfoP = InfoCmd <$> contestIdArg <*> contestInfoOpts + +contestInfoOpts :: Parser InfoOpts +contestInfoOpts = + InfoOpts + <$> optional + (Handle <$> strOption + ( long "user" + <> short 'u' + <> help + "Codeforces user handle. If specified, it shows the\ + \ contest details of another user. If not specified,\ + \ your contest details will be shown." + <> metavar "HANDLE" + ) + ) + <*> watchOpt + +friendsP :: Parser Command +friendsP = pure FriendsCmd + +openP :: Parser Command +openP = OpenCmd <$> contestIdArg + +problemsP :: Parser Command +problemsP = + fmap ProblemsCmd + $ ProblemOpts + <$> option + auto + ( long "minRating" + <> short 'r' + <> help "Filter problems by minimum rating." + <> showDefault + <> value 0 + <> metavar "INT" + ) + <*> option + auto + ( long "maxRating" + <> short 'R' + <> help "Filter problems by maximum rating." + <> showDefault + <> value 3500 + <> metavar "INT" + ) + +ratingsP :: Parser Command +ratingsP = RatingsCmd <$> handleArg + +setupP :: Parser Command +setupP = pure SetupCmd + +standingsP :: Parser Command +standingsP = StandingsCmd <$> contestIdArg <*> standingOpts + +standingOpts :: Parser StandingOpts +standingOpts = + StandingOpts + <$> switch + ( long "unofficial" + <> short 'u' + <> help + "If true then all participants (virtual, out of\ + \ competition) are shown. Otherwise, only official\ + \ contestants are shown." + ) + <*> fromOpt + <*> countOpt + <*> optional + (option + auto + ( long "room" + <> short 'r' + <> help + "If specified, then only participants from this room\ + \ are shown. Otherwise, all participants are shown." + <> metavar "INT" + ) + ) + <*> switch + ( long "friends" + <> short 'f' + <> help + "If true then only you and your friends will be shown\ + \ in the standings." + ) + <*> watchOpt + +statusP :: Parser Command +statusP = StatusCmd <$> handleArg <*> statusOpts + +statusOpts :: Parser StatusOpts +statusOpts = StatusOpts <$> fromOpt <*> countOpt <*> watchOpt + +userP :: Parser Command +userP = UserCmd <$> handleArg + +virtualP :: Parser Command +virtualP = + VirtualCmd + <$> contestIdArg + <*> handleArg + <*> argument auto (metavar "POINTS" <> help "Total points") + <*> argument auto (metavar "PENALTY" <> help "Total penalty") + +-------------------------------------------------------------------------------- + +handleArg :: Parser Handle +handleArg = + Handle <$> argument str (metavar "HANDLE" <> help "Codeforces user handle.") + +contestIdArg :: Parser ContestId +contestIdArg = ContestId + <$> argument auto (metavar "CONTEST_ID" <> help "ID of the contest") + +fromOpt :: Parser Int +fromOpt = option + auto + ( long "from" + <> short 'i' + <> help "1-based index of the row to start from." + <> showDefault + <> value 1 + <> metavar "INT" + ) + +countOpt :: Parser Int +countOpt = option + auto + ( long "count" + <> short 'n' + <> help "Number of rows to return." + <> showDefault + <> value 40 + <> metavar "INT" + ) + +watchOpt :: Parser Bool +watchOpt = switch $ long "watch" <> short 'w' <> help + "Watch this command and update output whenever it changes." + +-------------------------------------------------------------------------------- diff --git a/src/Codeforces/App/Table.hs b/src/Codeforces/App/Table.hs new file mode 100644 --- /dev/null +++ b/src/Codeforces/App/Table.hs @@ -0,0 +1,59 @@ +-------------------------------------------------------------------------------- + +module Codeforces.App.Table + ( Cell(..) + , Row + , Table + , makeTable + , ColConfig + ) where + +import Data.Text ( Text ) +import qualified Data.Text as T + +import System.Console.ANSI + +-------------------------------------------------------------------------------- + +-- | A cell of a table consists of SGR styles and some text content +data Cell = Cell [SGR] Text + +cellToText :: Cell -> Text +cellToText (Cell sgrs x) = + T.concat [T.pack $ setSGRCode sgrs, x, T.pack $ setSGRCode [Reset]] + +-------------------------------------------------------------------------------- + +-- | Name and width of a column +type ColConfig = (Text, Int) + +type Row = [Cell] + +-- | The table output is a list of row strings. +type Table = [Text] + +-- | `makeTable` @colConfigs rows@ returns a list of row strings including the +-- header row +makeTable :: [ColConfig] -> [Row] -> Table +makeTable hs rs = makeHeader hs : map (makeRow hs) rs + +makeHeader :: [ColConfig] -> Text +makeHeader hs = T.intercalate colSep $ map (\(s, w) -> pad w s) hs + +-- | `makeRow` @colConfigs row@ makes a row string from the supplied column +-- widths and row cells. +makeRow :: [ColConfig] -> Row -> Text +makeRow hs row = T.intercalate colSep paddedCells + where + paddedCells = zipWith (\(_, w) cell -> fmtCell w cell) hs row + fmtCell w (Cell sgrs x) = cellToText $ Cell sgrs (pad w x) + +colSep :: Text +colSep = " " + +pad :: Int -> Text -> Text +pad w s | len > w = T.take (w - 2) s <> ".." + | otherwise = s <> T.replicate (w - len) " " + where len = T.length s + +-------------------------------------------------------------------------------- diff --git a/src/Codeforces/App/Watcher.hs b/src/Codeforces/App/Watcher.hs new file mode 100644 --- /dev/null +++ b/src/Codeforces/App/Watcher.hs @@ -0,0 +1,142 @@ +-------------------------------------------------------------------------------- + +module Codeforces.App.Watcher where + +import Codeforces.App.Format +import Codeforces.App.Table +import Codeforces.Error +import Codeforces.Logging + +import Control.Concurrent +import Control.Exception ( bracket ) +import Control.Monad.Extra ( forM_ ) +import Control.Monad.Trans.Class +import Control.Monad.Trans.State + +import Data.Maybe ( catMaybes ) +import qualified Data.Text as T +import qualified Data.Text.IO as T +import Data.Time + +import System.Console.ANSI +import System.IO + +-------------------------------------------------------------------------------- + +-- | Values used for watching output. +data WatchState = WatchState + { wsTable :: Table + , wsUpdateTime :: Maybe UTCTime + } + +initWatchState :: WatchState +initWatchState = WatchState [] Nothing + +-------------------------------------------------------------------------------- + +-- | 'handleWatch' @shouldWatch m@ runs computation @m@ once if @shouldWatch@ is +-- false, otherwise 'watchTable' watches it. +-- +-- In the latter case, it clears the terminal and sets up terminal behaviour for +-- watching data. +-- +handleWatch :: Bool -> IO (Either CodeforcesError Table) -> IO () +handleWatch False m = + m >>= either (putStrLn . elErrorMsg . showE) (mapM_ T.putStrLn) +handleWatch True m = withDisabledStdin $ do + resetScreen + evalStateT (watchTable 2 m) initWatchState + +-- | 'watchTable' @delaySecs m@ runs computation @m@ every @delaySecs@ amount of +-- seconds. The terminal output from @m@ is changed if the next run of @m@ +-- yields a different result. +watchTable + :: Int -- ^ Delay, in seconds. + -> IO (Either CodeforcesError Table) -- ^ Fetches an updated table. + -> StateT WatchState IO () -- ^ Data from previous iteration. +watchTable delaySecs m = do + oldState <- get + now <- lift getCurrentTime + + output <- lift m >>= \case + Left e -> do + -- Include error message but table data remains the same + let oldTable = wsTable oldState + lastUpdate = wsUpdateTime oldState + pure $ addInfo oldTable (Just e) now lastUpdate + + Right newTable -> do + let currUpdate = Just now + put $ WatchState newTable currUpdate + pure $ addInfo newTable Nothing now currUpdate + + lift $ do + currTermH <- fmap fst <$> getTerminalSize + let output' = truncateTable output (subtract 1 <$> currTermH) + + setCursorPosition 0 0 + forM_ output' $ \r -> clearLine >> T.putStrLn r + + threadDelay (delaySecs * 1000000) + + watchTable delaySecs m + +-------------------------------------------------------------------------------- + +-- | Takes a table with a potential error message and last successful update +-- time, and returns the table with extra rows for various messages. +-- +-- When tables are displayed in watch mode, these extra rows are placed before +-- the table: +-- * The first displays a message for how to exit watch mode. +-- * The second row displays errors if there are any and the last update time. +-- * The third row is blank. +-- +addInfo + :: Table -- ^ Table to modify. + -> Maybe CodeforcesError -- ^ Error message, if exists. + -> UTCTime -- ^ Current system time. + -> Maybe UTCTime -- ^ Last successful update time, if any. + -> Table +addInfo table me now lastUpdate = + colored Cyan "Watching for updates. Press CTRL+c to exit." + : statusMsg + : "" + : table + where + statusMsg = T.concat $ catMaybes [errorMsg, updateMsg] + + errorMsg = colored Red . (<> ". ") . T.pack . elErrorMsg . showE <$> me + updateMsg = T.concat <$> sequenceA + [Just "Last update: ", fmtDiffTime <$> (diffUTCTime now <$> lastUpdate)] + +-- | 'truncateTable' @table x@ returns the table with the first @x@ rows, or the +-- original table if @x@ is @Nothing@. +truncateTable :: Table -> Maybe Int -> Table +truncateTable = maybe <*> flip take + +-------------------------------------------------------------------------------- + +resetScreen :: IO () +resetScreen = setSGR [Reset] >> clearScreen >> setCursorPosition 0 0 + +-- | Prevents any input into the terminal while running the IO computation. +withDisabledStdin :: IO a -> IO a +withDisabledStdin io = bracket + (do + prevBuff <- hGetBuffering stdin + prevEcho <- hGetEcho stdin + + -- Disable terminal input + hSetBuffering stdin NoBuffering + hSetEcho stdin False + + pure (prevBuff, prevEcho) + ) + (\(prevBuff, prevEcho) -> + -- Revert stdin buffering and echo + hSetBuffering stdin prevBuff >> hSetEcho stdin prevEcho + ) + (const io) + +-------------------------------------------------------------------------------- diff --git a/src/Codeforces/Config.hs b/src/Codeforces/Config.hs new file mode 100644 --- /dev/null +++ b/src/Codeforces/Config.hs @@ -0,0 +1,117 @@ +-------------------------------------------------------------------------------- + +module Codeforces.Config + ( UserConfig(..) + , AuthQuery(..) + , generateRequestParams + ) where + +import Codeforces.Types + +import qualified Crypto.Hash.SHA512 as SHA512 + +import Data.Aeson +import qualified Data.ByteString.Base16 as Base16 +import Data.ByteString.Char8 ( ByteString ) +import qualified Data.ByteString.Char8 as BC +import Data.Text ( Text ) +import qualified Data.Text.Encoding as T +import Data.Time.Clock.POSIX + +import Network.HTTP.Simple +import Network.HTTP.Types ( renderQuery ) + +import System.Random + +-------------------------------------------------------------------------------- + +-- | Represents the user's configuration settings. +-- +-- The API key must first be generated on +-- . +-- An API key consists of two parameters: @key@ and @secret@. +-- +-- To use the API key in a request, some parameters need to be generated from +-- this configuration. +-- +data UserConfig = UserConfig + { cfgHandle :: Handle -- ^ Codeforces handle of the user + , cfgKey :: Text -- ^ First part of the API key + , cfgSecret :: Text -- ^ Second part of the API key + } + deriving Show + +instance FromJSON UserConfig where + parseJSON = withObject "Config" $ \v -> + UserConfig <$> (v .: "handle") <*> (v .: "key") <*> (v .: "secret") + +instance ToJSON UserConfig where + toJSON UserConfig {..} = + object ["handle" .= cfgHandle, "key" .= cfgKey, "secret" .= cfgSecret] + +-------------------------------------------------------------------------------- + +-- | Contains the data needed to make an authorized GET request. +-- See 'generateRequestParams'. +data AuthQuery = AuthQuery + { aqOriginalQuery :: Query + , aqMethodName :: String + , aqKey :: Text + , aqSecret :: Text + , aqTime :: POSIXTime + , aqRand :: Int + } + +-- | 'generateRequestParams' @config path query@ returns a query string with +-- extra query items that are generated to allow for authorized access. +-- +-- The parameters are of the form: +-- @ +-- ?paramI=valueI&apiKey=&time=