module Utils.Katt.Upload
(makeSubmission)
where
import Control.Applicative ((<$>))
import Blaze.ByteString.Builder (fromByteString)
import qualified Utils.Katt.Configuration as C
import Control.Concurrent (threadDelay)
import Control.Error hiding (tryIO)
import Control.Monad.Reader
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 Network.Http.Client
import Utils.Katt.SourceHandler
import System.IO.Streams (write)
import Text.Parsec hiding (token)
import Text.Parsec.ByteString
import Utils.Katt.Utils
crlf :: B.ByteString
crlf = "\r\n"
data MultiPartField
= Option [B.ByteString] B.ByteString
| File FilePath
buildChunk :: B.ByteString -> MultiPartField -> IO B.ByteString
buildChunk langStr (File path) = do
file <- B.readFile path
return $ B.intercalate crlf [headerLine, "Content-Type: " <> langStr, "", file, ""]
where
headerLine = B.intercalate "; " ["Content-Disposition: form-data", "name=\"sub_file[]\"",
B.concat ["filename=\"", B.pack path, "\""]]
buildChunk _ (Option fields payload) = return $ B.intercalate crlf [headerLine, "", payload, ""]
where
headerLine = B.intercalate "; " fieldList
fieldList = "Content-Disposition: form-data" : fields
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] -> ConnEnv IO ()
makeSubmission filterArguments = do
exists <- liftIO C.projectConfigExists
tryAssert "No project configuration could be found."
exists
unWrapTrans C.loadProjectConfig
problem <- lift . lift $ (fromJust <$> S.gets project)
files <- tryIOMsg "Failed to locate source files" findFiles
let adjusted = adjust (parseFilter filterArguments) files
liftIO $ mapM_ (putStrLn . ("Adding file: "++)) adjusted
token <- authenticate
submission <- EitherT $ runReaderT
(runEitherT $ submitSolution (problem, adjusted)) token
tryIO . putStrLn $ "Made submission: " <> show submission
tryIO $ threadDelay initialTimeout
reestablishConnection
token' <- authenticate
reestablishConnection
EitherT $ runReaderT
(runEitherT $ checkSubmission submission) token'
where
adjust Nothing files = files
adjust (Just (add, sub)) files = union (files \\ sub) add
initialTimeout = 2000000
checkSubmission :: SubmissionId -> AuthEnv IO ()
checkSubmission submission = do
page <- retrievePrivatePage $
"/" <> 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
unWrapTrans reestablishConnection
checkSubmission 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 :: Submission -> AuthEnv IO SubmissionId
submitSolution (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 . liftIO $
(noteT "Failed to locate the \"public static void main\" method - is there any?" . hoistMaybe)
<$> findMainClass (files, language)
let multiPartSeparator = "separator"
conf <- lift . lift $ lift S.get
header <- makeSignedRequest $ do
http POST ("/" <> submitPage conf)
defaultRequest
setContentType $ B.append "multipart/form-data; boundary=" multiPartSeparator
problemName <- unWrapTrans $ retrieveProblemName problem
let postFields = [Option ["name=\"submit\""] "true"]
<> [Option ["name=\"submit_ctr\""] "2"]
<> [Option ["name=\"language\""] languageStr]
<> [Option ["name=\"mainclass\""] (B.pack mainClassStr)]
<> [Option ["name=\"problem\""] problemName]
<> [Option ["name=\"tag\""] ""]
<> [Option ["name=\"script\""] "true"]
<> map File files
unWrapTrans reestablishConnection
conn <- lift . lift $ S.get
tryIO $ sendRequest conn header (\o -> do
mapM_ (\part -> do
serialized <- buildChunk (languageContentType language) part
write (Just . fromByteString $ B.concat ["--", multiPartSeparator, crlf, serialized]) o)
postFields
write (Just . fromByteString $ B.concat ["--", multiPartSeparator, "--", crlf]) o
)
reply <- tryIO $ receiveResponse conn concatHandler
(EitherT . return . fmapL (B.pack . show)) $
parse parseSubmissionId "Submission ID parser" reply
where
parseSubmissionId = manyTill anyChar (lookAhead identifier) >> identifier
identifier = read <$> many1 digit