module Utils.Katt.Upload
(makeSubmission)
where
import Control.Applicative ((<$>))
import Control.Concurrent (threadDelay)
import Control.Error hiding (tryIO)
import Control.Lens
import Control.Monad(join, liftM2, void)
import qualified Control.Monad.State as S
import qualified Data.ByteString.Char8 as B
import Data.List ((\\), union, findIndex)
import Data.Maybe (fromJust)
import Data.Monoid ((<>))
import qualified Data.Text as T
import qualified Network.Wreq as W
import qualified Network.Wreq.Session as WS
import Text.Parsec hiding (token)
import Text.Parsec.ByteString
import qualified Utils.Katt.Configuration as C
import Utils.Katt.SourceHandler
import Utils.Katt.Utils
submissionPage :: B.ByteString
submissionPage = "submission"
data SubmissionState
= Queued
| Compiling
| Running
| WrongAnswer
| TimeLimitExceeded
| Accepted
| CompileError
| RunTimeError
| Other
deriving (Eq, Show)
data TestCase
= TestPassed
| TestFailed
| NotTested
deriving (Eq, Show)
finalSubmissionState :: SubmissionState -> Bool
finalSubmissionState s = elem s
[WrongAnswer, TimeLimitExceeded, Accepted, CompileError, RunTimeError, Other]
makeSubmission :: [String] -> ConfigEnv IO ()
makeSubmission filterArguments = do
exists <- tryIO C.projectConfigExists
tryAssert "No project configuration could be found."
exists
C.loadProjectConfig
problem <- fromJust <$> S.gets project
conf <- S.get
files <- tryIOMsg "Failed to locate source files" findFiles
let adjusted = adjust (parseFilter filterArguments) files
tryIO $ mapM_ (putStrLn . ("Adding file: "++)) adjusted
let url = buildURL (host conf) (submitPage conf)
toState sess = (sess, host conf)
submission <- withAuth $\sess ->
submitSolution (toState sess) url (problem, adjusted)
tryIO $ do
putStrLn $ "Made submission: " <> show submission
threadDelay initialTimeout
withAuth $\sess ->
checkSubmission (toState sess) submission
where
adjust Nothing files = files
adjust (Just (add, sub)) files = union (files \\ sub) add
initialTimeout = 2000000
checkSubmission :: Session -> SubmissionId -> EitherT ErrorDesc IO ()
checkSubmission sess submission = do
page <- retrievePrivatePage sess $
submissionPage <> "?id=" <> B.pack (show submission)
let (state, tests) = parseSubmission page
if finalSubmissionState state
then
tryIO $ printResult tests state
else do
tryIO $ putStrLn "Waiting for completion.." >> threadDelay interval
checkSubmission sess submission
where
interval = 1000000
parseSubmission :: B.ByteString -> (SubmissionState, [TestCase])
parseSubmission contents =
case res of
Left err' -> error $ "Internal parser error" <> show err'
Right res' -> res'
where
res = parse parser "Submission parser" contents
parser = liftM2 (,) parseStatus parseTestCases
strSep :: GenParser Char st ()
strSep = void (char '\'' <|> char '"')
endTag :: GenParser Char st ()
endTag = void $ manyTill anyChar (char '>')
parseStatus :: GenParser Char st SubmissionState
parseStatus = skip >> status
where
beginStatus = do
void $ string "<td class="
strSep >> string "status" >> strSep >> endTag
void $ string "<span class=" >> strSep
skip = manyTill anyChar (void (try beginStatus) <|> eof)
status = do
void $ manyTill anyChar strSep
endTag
statusStr <- manyTill (letter <|> space) (char '<')
return $ conv statusStr
conv "Time Limit Exceeded" = TimeLimitExceeded
conv "Wrong Answer" = WrongAnswer
conv "Accepted" = Accepted
conv "Memory Limit Exceeded" = Other
conv "Compiling" = Compiling
conv "Running" = Running
conv "Compile Error" = CompileError
conv "Run Time Error" = RunTimeError
conv _ = Other
parseTestCases :: GenParser Char st [TestCase]
parseTestCases = skip >> tests
where
beginTests = do
void $ string "<div class="
strSep >> string "testcases" >> strSep
endTag
skip = manyTill anyChar (void (try beginTests) <|> eof)
tests = many testCase
testCase = do
void . try $ string "<span "
classResult <- optionMaybe $ do
string "class=" >> strSep
manyTill anyChar strSep
void . manyTill anyChar $ string "</span>"
fromMaybe (return NotTested) (mapResult <$> classResult)
mapResult "accepted" = return TestPassed
mapResult "rejected" = return TestFailed
mapResult _ = parserZero
printResult :: [TestCase] -> SubmissionState -> IO ()
printResult tests state
| state == Accepted = putStrLn $ "Accepted, " <> numTests <> " test(s) passed."
| null tests = putStrLn resultStr
| otherwise = putStrLn $ resultStr <> testCaseStr
where
numTests = show $ length tests
firstFailed = show . (+1) . fromMaybe 0 $ findIndex (/= TestPassed) tests
resultStr = "Result: " <> show state
testCaseStr = ", failed on test case " <> firstFailed <> " of " <> numTests
submitSolution :: Session -> String -> Submission -> EitherT ErrorDesc IO SubmissionId
submitSolution (sess, _) url (problem, files) = do
language <- noteT ("\nFailed to decide submission language\n" <>
"Please use either Java or some union of C++ and C")
. hoistMaybe $ determineLanguage files
let languageStr = languageKattisName language
mainClassStr <- join . tryIO $
(noteT "Failed to locate the \"public static void main\" method - is there any?" . hoistMaybe)
<$> findMainClass (files, language)
problemName <- tryIO $retrieveProblemName problem
let files' = map (W.partFile "sub_file[]") files
conv = T.pack . B.unpack
postFields = [W.partText "submit" "true"]
<> [W.partText "submit_ctr" "2"]
<> [W.partText "language" (conv languageStr)]
<> [W.partText "mainclass" (T.pack mainClassStr)]
<> [W.partText "problem" (conv problemName)]
<> [W.partText "tag" ""]
<> [W.partText "script" "true"]
reply <- tryIO $WS.postWith
defaultOpts
sess
url
(files' <> postFields)
let body = reply ^. W.responseBody
(EitherT . return . fmapL (B.pack . show)) $
parse parseSubmissionId "Submission ID parser" body
where
parseSubmissionId = manyTill anyChar (lookAhead identifier) >> identifier
identifier = read <$> many1 digit