diff --git a/katt-cli/src/Main.hs b/katt-cli/src/Main.hs new file mode 100644 --- /dev/null +++ b/katt-cli/src/Main.hs @@ -0,0 +1,78 @@ +{-# Language OverloadedStrings #-} + +-------------------------------------------------------------------- +-- | +-- Module : Main +-- +-- Entry point of the program. +-- +-- Begins by locating a global configuration file, and upon success +-- parses the given arguments and executes the corresponding submodule. +-- + +module Main(main) where + +import qualified Utils.Katt.Configuration as C +import Control.Monad.State +import qualified Data.ByteString.Char8 as B +import Data.Monoid ((<>)) +import Utils.Katt.Init +import Network.Http.Client +import OpenSSL (withOpenSSL) +import System.Environment +import System.Exit (exitFailure) +import Utils.Katt.Upload +import Utils.Katt.Utils + +-- | Main loads the global config and runs argument parsing. +main :: IO () +main = do + conf <- C.loadGlobalConfig + conf' <- case conf of + Left err -> do + B.putStrLn $ "Kattis configuration error: " <> err + printHelp + exitFailure + Right c -> return c + + withOpenSSL $ parseArgs conf' + +-- | Given some configuration state, parse arguments and +-- run the appropiate submodule. +-- Output help text upon failure to parse arguments. +parseArgs :: ConfigState -> IO () +parseArgs conf = getArgs >>= parse + where + parse :: [String] -> IO () + parse ("init" : problem : []) = withConn conf . initializeProblem True True . ProblemName $ B.pack problem + parse ("init-session" : session : []) = withConn conf . initializeSession True $ read session + parse ("submit" : filterList) = withConn conf $ makeSubmission filterList + parse _ = printHelp + +-- | Print help text. +printHelp :: IO () +printHelp = putStrLn $ + "The following commands are available:\n\n" <> + "init \n" <> + " Create the corresponding directory and download any available tests.\n\n" <> + "init-session \n" <> + " Initialize all problems associated to the problem session, given as an integer id.\n\n" <> + "submit [+add_file] [-skip_file]\n" <> + " Make a submission using the problem name read from a local config.\n" <> + " Defaults to recursively including all source and header files that can be found.\n" <> + " Use the optional filter arguments to include or exclude files.\n\n" <> + "Note that you will need a valid configuration file (placed in ~/.kattisrc), such as:\n" <> + "https://www.kattis.com/download/kattisrc\n" + +-- | Given some action, initiate a connection and run it. +-- Connections are layered using StateT since they may be reestablished. +withConn :: ConfigState -> ConnEnv IO a -> IO a +withConn conf action = do + B.putStrLn $ "Connecting to host: " <> host conf + conn <- establishConnection (host conf) + ((res, conn'), _) <- runStateT (withConf conn) conf + closeConnection conn' + return res + + where + withConf = runStateT (terminateOnFailure "Failed to run command" action) diff --git a/katt-lib/src/Utils/Katt/Configuration.hs b/katt-lib/src/Utils/Katt/Configuration.hs new file mode 100644 --- /dev/null +++ b/katt-lib/src/Utils/Katt/Configuration.hs @@ -0,0 +1,121 @@ +{-# Language OverloadedStrings, NoMonomorphismRestriction #-} + +-------------------------------------------------------------------- +-- | +-- Module : Utils.Katt.Configuration +-- +-- Implements loading and saving of global and local configurations. +-- All configurations are stored in the 'ConfigFile' format, which is +-- fully compatible with the official Kattis configuration file. +-- +-- The global configuration file corresponds to /kattisrc/, which holds +-- information regarding authentication and hosts. +-- +-- The local configuration holds project-specific information and +-- is created by the 'Init' submodule. +-- Currently only the problem name is stored. + +module Utils.Katt.Configuration +(loadGlobalConfig, projectConfigExists, loadProjectConfig, saveProjectConfig) +where + +import Control.Error hiding (tryIO) +import Control.Monad +import qualified Control.Monad.State as S +import Control.Monad.Trans (liftIO, lift) +import qualified Data.ByteString.Char8 as B +import Data.ConfigFile +import Data.Monoid ((<>)) +import qualified Network.URL as U +import System.Directory (getHomeDirectory) +import System.IO +import System.IO.Error (catchIOError) +import Utils.Katt.Utils + +-- | Path to global configuration file, relative home directory. +globalConfigFile :: FilePath +globalConfigFile = ".kattisrc" + +-- | Path to project-specific (local) configuration file. +projectConfigFile :: FilePath +projectConfigFile = B.unpack $ configDir <> "/" <> "config" + +-- | Serialize error description into bytestring. +convertErrorDesc :: (Show a) => (a, String) -> B.ByteString +convertErrorDesc (errorData, str) = B.pack (show errorData) <> B.pack str + +-- | Retrieve a field from the configuration state using a key and section, +-- possibly failing. +get' :: (Monad m, Get_C r) => ConfigParser -> SectionSpec -> String -> EitherT B.ByteString m r +get' conf section key = fmapLT + (const . B.pack $ "Failed to parse " <> key <> " field") + (get conf section key) + +-- | Load global configuration file and parse the configuration state. +-- Ensures that all fields are present and validates the URLs. +loadGlobalConfig :: IO (Either ErrorDesc ConfigState) +loadGlobalConfig = runEitherT $ do + home <- tryIO getHomeDirectory + let filePath = home <> "/" <> globalConfigFile + + fileHandle <- tryIOMsg ("Failed to open " <> B.pack filePath) $ + openFile filePath ReadMode + conf <- fmapLT convertErrorDesc $ join . liftIO $ readhandle emptyCP fileHandle + + user' <- get' conf "user" "username" + apiKey' <- get' conf "user" "token" + + loginURL <- get' conf "kattis" "loginurl" + loginParsed <- extract "Failed to parse loginurl field" loginURL + + submitURL <- get' conf "kattis" "submissionurl" + submitParsed <- extract "Failed to parse submissionurl field" submitURL + + host' <- parseHost loginParsed + + tryIOMsg "Failed to close configuration file handle" $ hClose fileHandle + + return $ ConfigState + (B.pack user') + (B.pack apiKey') + (B.pack $ "https://" <> host') + (B.pack $ U.url_path loginParsed) + (B.pack $ U.url_path submitParsed) + Nothing + + where + extract msg = noteT msg . hoistMaybe . U.importURL + parseHost (U.URL (U.Absolute host') _ _) = return $ U.host host' + parseHost _ = left "Invalid URL format" + +-- | Check if a project-specific configuration file exists and can be read. +projectConfigExists :: IO Bool +projectConfigExists = catchIOError open . const $ return False + where + open = withFile projectConfigFile ReadMode . const $ return True + +-- | Load a project-specific configuration based on the current directory. +loadProjectConfig :: ConfigEnv IO () +loadProjectConfig = do + conf <- fmapLT convertErrorDesc $ join . liftIO $ readfile emptyCP projectConfigFile + problem <- get' conf "problem" "problemname" + lift . S.modify $ \s -> s { project = Just . ProblemName $ B.pack problem} + +-- | Save a project-specific configuration file to disk. +saveProjectConfig :: ConnEnv IO () +saveProjectConfig = do + project' <- lift . lift $ S.gets project + state <- noteT "Tried to save an empty project configuration." . hoistMaybe $ project' + problemName <- retrieveProblemName state + serialized <- serialize problemName + tryIOMsg (B.pack $ + "Failed to save project configuration file (path: " + <> projectConfigFile <> ")") $ + writeFile projectConfigFile (to_string serialized) + + where + serialize problemName = EitherT . return . fmapL convertErrorDesc $ do + let conf = emptyCP + conf' <- add_section conf "problem" + conf'' <- add_section conf' "submissions" + set conf'' "problem" "problemname" $ B.unpack problemName diff --git a/katt-lib/src/Utils/Katt/Init.hs b/katt-lib/src/Utils/Katt/Init.hs new file mode 100644 --- /dev/null +++ b/katt-lib/src/Utils/Katt/Init.hs @@ -0,0 +1,205 @@ +{-# Language OverloadedStrings, ScopedTypeVariables, + NoMonomorphismRestriction #-} + +-------------------------------------------------------------------- +-- | +-- Module : Utils.Katt.Init +-- +-- Init submodule providing initialization of problems +-- and entire problem sessions. +-- +-- Problems are initialized by creating a directory, configuration file, +-- and optionally downloading all test files available. +-- Both zip-based test data and embedded HTML tables are supported. +-- +-- Problem sessions are initialized by parsing the list of problems and +-- initializing each problem separately. + +module Utils.Katt.Init +(initializeProblem, initializeSession) +where + +import Control.Applicative ((<$>), (<*)) +import Codec.Archive.Zip +import Control.Arrow ((***)) +import qualified Control.Monad.State as S +import qualified Utils.Katt.Configuration as C +import Control.Error hiding (tryIO) +import qualified Control.Exception as E +import Control.Monad.Reader +import qualified Data.ByteString.Char8 as B +import qualified Data.ByteString.Lazy.Char8 as BL +import Data.Foldable (fold) +import Data.List (isSuffixOf, nub) +import Data.Monoid ((<>)) +import System.Directory +import System.IO (stderr) +import Text.Parsec hiding (token) +import Text.Parsec.ByteString +import Utils.Katt.Utils + +-- | Parsed test cases associated with a problem. +type TestContent = [(B.ByteString, B.ByteString)] + +-- | Possible test case scenarios. +data TestParser + -- | No tests available. + = NoTestsAvailable + -- | Test content available in zip file, given as URL. + | TestAddress B.ByteString + -- | Embedded test content. + | TestContents TestContent + deriving Show + +-- | Parse the possible different test file cases, given the problem page. +-- Any zip download links are preferred over embedded test data. +parseProblemPage :: B.ByteString -> TestParser +parseProblemPage contents = + case res of + Left _ -> NoTestsAvailable + Right test -> test + where res = parse (try parseAddress <|> parseEmbedded) "Test parser" contents + +-- | Try to parse a download URL from the supplied page data. +parseAddress :: GenParser Char st TestParser +parseAddress = do + void $ manyTill anyChar (try $ startLink >> lookAhead endParser) + TestAddress . B.cons '/' . B.pack <$> endParser + + where + startLink = string " tests + where + sp = skipMany $ space <|> newline <|> tab + beginTag tag = void $ char '<' >> sp >> string tag >> sp >> char '>' + endTag tag = void $ char '<' >> sp >> char '/' >> string tag >> sp >> char '>' + htmlTag tag p = do + sp >> beginTag tag >> sp + manyTill p $ try $ endTag tag + + tr = htmlTag "tr" + td = htmlTag "td" + pre = htmlTag "pre" + + tests = manyTill anyChar (lookAhead startTable) >> endBy1 testTable sp + + startTable = void . try $ string "" + endTable = void $ string "
" + + testTable = do + startTable + inner <- tableBody + sp >> endTable + return inner + + tableBody = do + void $ tr anyChar + try (fold <$> tr testCase) <* sp + + innerTestData = do + sp + B.pack <$> pre anyChar <* sp + + testData = liftM fold $ td innerTestData <* sp + testCase = liftM2 (,) testData testData + +-- | Retrieve the zip archive located at the specified URL and unzip the contents. +-- Matches input and output file pairs, producing a list of tuples. +downloadTestArchive :: B.ByteString -> ConnEnv IO TestContent +downloadTestArchive url = do + reestablishConnection + zipFile <- BL.fromChunks . return <$> retrievePublicPage url + zipEntries <- tryIOMsg "Failed to unpack zip file: corrupt archive" $ + E.evaluate (zEntries $ toArchive zipFile) + + let filterFiles suffix = filter (isSuffixOf suffix . eRelativePath) zipEntries + inFiles = filterFiles inputTestExtension + outFiles = filterFiles outputTestExtension + + tryAssert "Failed to unpack zip file: no test files found" $ + not (null zipEntries) + tryAssert "Failed to unpack zip file: input and reference count doesn't match" $ + length inFiles == length outFiles + + return $ zipWith (curry convertEntry) inFiles outFiles + where + convertEntry = getData *** getData + getData = fold . BL.toChunks . fromEntry + +-- | Retrieve test cases, which fall into either one of the three categories. +retrieveTestFiles :: KattisProblem -> ConnEnv IO TestContent +retrieveTestFiles problem = do + problemName <- retrieveProblemName problem + problemPage <- retrievePublicPage $ problemAddress <> problemName + + case parseProblemPage problemPage of + NoTestsAvailable -> do + tryIO $ B.hPutStrLn stderr "No tests available" + return [] + TestAddress addr -> downloadTestArchive addr + TestContents list -> return list + +-- | Page listing all problems associated with a problem session, relative 'Utils.host'. +sessionPage :: B.ByteString +sessionPage = "/standings/?sid=" + +-- | Parse a problem session page, locating all the associated problem names. +parseProblemList :: GenParser Char st [KattisProblem] +parseProblemList = skip >> endBy1 tag skip + where + beginLink = string " ProblemSession -> ConnEnv IO () +initializeSession retrieveTests session = do + contents <- retrievePublicPage $ sessionPage <> (B.pack $ show session) + problems <- nub <$> (EitherT . return . fmapL (B.pack . show) $ parse' contents) + mapM_ (\problem -> do + reestablishConnection + initializeProblem True retrieveTests problem + restoreDir + ) + problems + where + parse' contents = parse (parseProblemList) "Problem list parser" contents + restoreDir = liftIO $ setCurrentDirectory ".." + -- TODO: restore to previously used directory + +-- | Given a problem identifier, setup directory structures and +-- optionally download test cases. +initializeProblem :: Bool -> Bool -> KattisProblem -> ConnEnv IO () +initializeProblem mkDir retrieveTests problem = do + liftIO . putStrLn $ "Initializing problem: " <> show problem + problemName <- retrieveProblemName problem + tryIO . when mkDir $ do + createDirectoryIfMissing False (B.unpack problemName) + setCurrentDirectory (B.unpack problemName) + + tryIO $ createDirectoryIfMissing False (B.unpack configDir) + + fileExists <- liftIO C.projectConfigExists + tryAssert + "Project configuration file already exists, please remove it in order to continue." + (not fileExists) + + lift . lift . S.modify $ \s -> s { project = Just $ ProblemName problemName } + C.saveProjectConfig + + when retrieveTests $ do + tryIO $ createDirectory testFolder + files <- zip [1..] <$> retrieveTestFiles problem + mapM_ (\(n :: Integer, (input, output)) -> do + let fileName = testFolder <> "/" <> B.unpack problemName <> "-" <> show n + tryIO $ B.writeFile (fileName <> inputTestExtension) input + tryIO $ B.writeFile (fileName <> outputTestExtension) output) + files diff --git a/katt-lib/src/Utils/Katt/SourceHandler.hs b/katt-lib/src/Utils/Katt/SourceHandler.hs new file mode 100644 --- /dev/null +++ b/katt-lib/src/Utils/Katt/SourceHandler.hs @@ -0,0 +1,116 @@ +{-# Language OverloadedStrings #-} + +-------------------------------------------------------------------- +-- | +-- Module : Utils.Katt.SourceHandler +-- +-- Provides searching of source code files and language identification. +-- +-- Language identification is required in order to detect any +-- inconsistencies (e.g. combining Java and C), and to tag submissions. +-- +-- Java also requires identifying which file provides the main method. + +module Utils.Katt.SourceHandler +(parseFilter, findFiles, determineLanguage, findMainClass, languageKattisName, languageContentType) +where + +import Control.Applicative ((<$>)) +import Control.Arrow ((***)) +import Control.Monad +import qualified Data.ByteString.Char8 as B +import Data.List +import qualified Data.Set as Set +import System.Directory +import System.FilePath (takeBaseName, takeExtension) +import Text.Parsec +import Text.Parsec.ByteString +import Utils.Katt.Utils + +-- | All supported source file extensions, per language. +supported :: KattisLanguage -> Set.Set FilePath +supported LangCplusplus = Set.fromList [".cc", ".cpp", ".hpp", ".h"] +supported LangC = Set.fromList [".c", ".h"] +supported LangJava = Set.fromList [".java"] + +-- | Parse an argument list from the +file1 -file2 style into +-- two lists of file paths (included and ignored files). +parseFilter :: [String] -> Maybe ([FilePath], [FilePath]) +parseFilter input = (filter' *** filter') <$> mapAndUnzipM go input + where + go ('+' : file) = Just (file, "") + go ('-' : file) = Just ("", file) + go _ = Nothing + filter' = filter (not . null) + +-- | Locate all source files recursively from the current directory. +findFiles :: IO [FilePath] +findFiles = explore "" "." + where + explore prefix dir = do + contents <- (\\ [".", ".."]) <$> getDirectoryContents dir + let withPrefix = map (prefix++) contents + + dirs <- filterM doesDirectoryExist withPrefix + let sourceFiles = filter isValidSourceFile (withPrefix \\ dirs) + nextDepth <- mapM exploreDir dirs + return $ sourceFiles ++ concat nextDepth + + isValidSourceFile file = any (`isSuffixOf` file) + (Set.toList . Set.unions $ map supported [LangCplusplus, LangC, LangJava]) + exploreDir dir = explore (dir ++ "/") dir + +-- | Determine source code language by studying file extensions. +-- There is an implicit priority ordering, since C is a subset of C++. +determineLanguage :: [FilePath] -> Maybe KattisLanguage +determineLanguage files + | is LangC = Just LangC + | is LangCplusplus = Just LangCplusplus + | is LangJava = Just LangJava + | otherwise = Nothing + where + fileSet = Set.fromList $ map takeExtension files + is lang = fileSet `Set.isSubsetOf` (supported lang) + +-- | Locate main class based on source file contents. +-- C++ and C solutions do not need to be specified, returns an empty string. +-- +-- In the Java case all souce code files are parsed. +-- All occurences of a /main/ method defined with /public static void/ are located. +-- +-- Will return 'Data.Maybe.Nothing' if result is ambiguous. +findMainClass :: ([FilePath], KattisLanguage) -> IO (Maybe FilePath) +findMainClass ([], _) = return Nothing +findMainClass (_, LangCplusplus) = return $ Just "" +findMainClass (_, LangC) = return $ Just "" +findMainClass (files, LangJava) = survey <$> filterM containsMain files + where + containsMain file = do + parseResult <- parseFromFile mainParser file + case parseResult of + Right _ -> return True + Left _ -> return False + + mainParser = manyTill + (lineComment <|> blockComment <|> stringData <|> void anyChar) + mainFunc + blockComment = void $ string "/*" >> manyTill anyChar (try $ string "*/") + lineComment = void . try $ string "//" >> manyTill anyChar newline + stringData = void $ char '"' >> manyTill anyChar (char '"') + mainFunc = try $ mapM_ keyWord ["public", "static", "void", "main"] + keyWord str = void $ string str >> spaces + + survey [singleton] = Just $ takeBaseName singleton + survey _ = Nothing + +-- | Determine content type of submission language. +languageContentType :: KattisLanguage -> B.ByteString +languageContentType LangCplusplus = "text/x-c++src" +languageContentType LangJava = "text/x-c++src" +languageContentType LangC = "text/x-c++src" + +-- | Determine Kattis language string identifier. +languageKattisName :: KattisLanguage -> B.ByteString +languageKattisName LangCplusplus = "C++" +languageKattisName LangJava = "Java" +languageKattisName LangC = "C" diff --git a/katt-lib/src/Utils/Katt/Upload.hs b/katt-lib/src/Utils/Katt/Upload.hs new file mode 100644 --- /dev/null +++ b/katt-lib/src/Utils/Katt/Upload.hs @@ -0,0 +1,325 @@ +{-# Language OverloadedStrings, ScopedTypeVariables #-} + +-------------------------------------------------------------------- +-- | +-- Module : Utils.Katt.Upload +-- +-- Upload submodule providing submissions of solutions and parsing of results. +-- +-- A submission is done by including all recursively found files and filtering +-- using a file filter given as an argument. +-- This is followed by polling for a submission result until some final +-- submission state has been reached (e.g. accepted). +-- +-- Currently multipart data upload is implemented since https-streams +-- (the HTTP client being used) does not support it (yet?). + +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 + +-- | Line separator used in HTTP headers. +crlf :: B.ByteString +crlf = "\r\n" + +-- | Multipart field consisting of an option or file. +data MultiPartField + -- | Option built using a list of assignments and a payload. + = Option [B.ByteString] B.ByteString + -- | File to submitted, path given. + | File FilePath + +-- | Serialize a chunk based on a file to be submitted. +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, "\""]] + +-- | Serialize a chunk based on an option. +buildChunk _ (Option fields payload) = return $ B.intercalate crlf [headerLine, "", payload, ""] + where + headerLine = B.intercalate "; " fieldList + fieldList = "Content-Disposition: form-data" : fields + +-- | Submission page URL, relative 'Utils.host', from which specific submission can be requested. +submissionPage :: B.ByteString +submissionPage = "submission" + +-- | Possible states of a submission, with unknowns being grouped into 'Other'. +data SubmissionState + -- | Submission is queued. + = Queued + -- | Submission is compiling. + | Compiling + -- | Submission is running. + | Running + -- | Wrong answer. + | WrongAnswer + -- | Time limit exceeded. + | TimeLimitExceeded + -- | Submission was accepted (only success state). + | Accepted + -- | Compile error. + | CompileError + -- | Run time error. + | RunTimeError + -- | Some other, unmatched error code. Only used when parsing fails. + | Other + deriving (Eq, Show) + +-- | Possible states of a single test case, i.e. an (input, output) data pair. +data TestCase + -- | Test case passed. + = TestPassed + -- | Test case failed (state /= Accepted) + | TestFailed + -- | Test case has not been executed. + | NotTested + deriving (Eq, Show) + +-- | Check if a given state is final, i.e. won't transition into some other. +-- Note that 'Other' is listed as final. +finalSubmissionState :: SubmissionState -> Bool +finalSubmissionState s = elem s + [WrongAnswer, TimeLimitExceeded, Accepted, CompileError, RunTimeError, Other] + +-- | Make a submission of the project in the working directory. +-- Accepts a list of filters on the form /+file1 -file2 ../, which are +-- taken into account when locating all the source files. +-- /+file/ implies adding the specified file. +-- /-file/ implies removing the specified file. +-- +-- In addition to the filters, all recursively found source code files +-- will be included in the submission. +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) + + -- Locate all source files, filter based on filter list. + files <- tryIOMsg "Failed to locate source files" findFiles + let adjusted = adjust (parseFilter filterArguments) files + + liftIO $ mapM_ (putStrLn . ("Adding file: "++)) adjusted + + -- Authenticate, submit files, and retrieve submission id. + token <- authenticate + + submission <- EitherT $ runReaderT + (runEitherT $ submitSolution (problem, adjusted)) token + + tryIO . putStrLn $ "Made submission: " <> show submission + tryIO $ threadDelay initialTimeout + + -- Reauthenticate to allow future requests. + reestablishConnection + token' <- authenticate + + -- Poll submission page until completion. + reestablishConnection + EitherT $ runReaderT + (runEitherT $ checkSubmission submission) token' + + where + adjust Nothing files = files + adjust (Just (add, sub)) files = union (files \\ sub) add + + -- Initial timeout before requesting updates is 2 s. + initialTimeout = 2000000 + +-- | Poll kattis for updates on a submission. +-- This function returns when the submission has reached one of the final states. +-- TODO: Consider exponential back-off and timeout +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 + -- Default poll interval is 1 s. + interval = 1000000 + +-- | Parse the supplied submission page into: +-- (1) Current submission state +-- (2) Status of all test cases +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 + +-- | String separator parser. +strSep :: GenParser Char st () +strSep = void (char '\'' <|> char '"') + +-- | End-of-tag parser, ignores everything up to the end of the current tag. +endTag :: GenParser Char st () +endTag = void $ manyTill anyChar (char '>') + +-- | Parse the submission status field, beginning from any offset in the page data. +parseStatus :: GenParser Char st SubmissionState +parseStatus = skip >> status + where + beginStatus = do + void $ string "> strSep >> endTag + void $ string "> tests + where + beginTests = do + void $ string "
> strSep + endTag + + -- Locate surrounding div tag. + skip = manyTill anyChar (void (try beginTests) <|> eof) + + -- Parse all test cases. + tests = many testCase + + -- Each test case is basically ... + -- where a missing class attribute implies that it hasn't been executed. + testCase = do + void . try $ string "" + fromMaybe (return NotTested) (mapResult <$> classResult) + + mapResult "accepted" = return TestPassed + mapResult "rejected" = return TestFailed + mapResult _ = parserZero + +-- | Print the result of a submission. +-- Will also take care of the special case when no test cases were parsed. +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 + + +-- | Submit a solution, given problem name and source code files. +submitSolution :: Submission -> AuthEnv IO SubmissionId +submitSolution (problem, files) = do + -- Determine language in submission. + 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) + + -- Build HTTP headers and form. + 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 + + -- Send request. Connection is reestablished. + 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 + ) + + -- Receive server response and parse submission ID. + 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 diff --git a/katt-lib/src/Utils/Katt/Utils.hs b/katt-lib/src/Utils/Katt/Utils.hs new file mode 100644 --- /dev/null +++ b/katt-lib/src/Utils/Katt/Utils.hs @@ -0,0 +1,231 @@ +{-# Language OverloadedStrings, ScopedTypeVariables, + NoMonomorphismRestriction #-} + +-------------------------------------------------------------------- +-- | +-- Module : Utils.Katt.Utils +-- +-- Contains shared type declarations and various utility functions. +-- + +module +Utils.Katt.Utils +where + +import Control.Applicative ((<$>)) +import Control.Error hiding (tryIO) +import qualified Control.Exception as E +import Control.Monad.Reader +import qualified Control.Monad.State as S +import qualified Data.ByteString.Char8 as B +import Data.Monoid ((<>)) +import Network.Http.Client +import System.Exit (exitFailure) +import System.IO (stderr) +import System.IO.Streams (readExactly) + +-- | Configuration layer consisting of configuration state. +type ConfigEnvInternal m = S.StateT ConfigState m +-- | Configuration layer wrapped with error handling. +type ConfigEnv m = EitherT ErrorDesc (ConfigEnvInternal m) + +-- | Connection layer with connection state layered on the configuration layer. +type ConnEnvInternal m = S.StateT Connection (ConfigEnvInternal m) +-- | Connection layer wrapped with error handling. +type ConnEnv m = EitherT ErrorDesc (ConnEnvInternal m) + +-- | Authentication layer with token state and error handling, +-- wrapping the connection layer. +type AuthEnv m = EitherT ErrorDesc (ReaderT B.ByteString (ConnEnvInternal m)) + +-- | Submissions consist of a problem identifier and a set of file paths. +type Submission = (KattisProblem, [FilePath]) + +-- | Error description alias. +type ErrorDesc = B.ByteString + +-- | Submissions are identified with an integer id. +type SubmissionId = Integer +-- +-- | Problem sessions are identified with an integer id. +type ProblemSession = Integer + +-- | Project-specific state consists of the problem name. +type ProjectState = (KattisProblem) + +-- | Global configuration, initialized from the /.kattisrc/ file. +data ConfigState = + ConfigState { + -- | Username. + user :: B.ByteString, + -- | API token (hash). + apiKey :: B.ByteString, + -- | Host to be considered as service. + host :: B.ByteString, + -- | URL to login page, relative 'host'. + loginPage :: B.ByteString, + -- | URL to submit page, relative 'host'. + submitPage :: B.ByteString, + -- | Project-specific state, optionally loaded. + project :: Maybe ProjectState + } + deriving Show + +-- | A Kattis problem. +data KattisProblem + -- | Problem ID, unique. + = ProblemId Integer + -- | Associated name of the problem. + | ProblemName B.ByteString + deriving (Eq, Show) + +-- | Language used in submission. +data KattisLanguage + -- | C++. + = LangCplusplus + -- | Java. + | LangJava + -- | C. + | LangC + deriving (Eq, Show) + +-- | Server response indicating successful login. +loginSuccess :: B.ByteString +loginSuccess = "Login successful" + +-- | Extension of input test files. +inputTestExtension :: FilePath +inputTestExtension = ".in" + +-- | Extension of reference ouput test files. +outputTestExtension :: FilePath +outputTestExtension = ".ans" + +-- | Name of this program. +programName :: B.ByteString +programName = "katt" + +-- | Relative path to project-specific configuration directory. +configDir :: B.ByteString +configDir = "." <> programName + +-- | Relative path to folder containing tests. +testFolder :: FilePath +testFolder = "tests" + +-- | URL to page with problem information, relative to 'host'. +problemAddress :: B.ByteString +problemAddress = "/problems/" + +-- | Lift some error monad one layer. +unWrapTrans :: (Monad m, MonadTrans t) => EitherT e m a -> EitherT e (t m) a +unWrapTrans = EitherT . lift . runEitherT + +-- | Execute an IO action and catch any exceptions. +tryIO :: MonadIO m => IO a -> EitherT ErrorDesc m a +tryIO = EitherT . liftIO . liftM (fmapL (B.pack . show)) . + (E.try :: (IO a -> IO (Either E.SomeException a))) + +-- | Execute an IO action and catch any exceptions, tagged with description. +tryIOMsg :: MonadIO m => B.ByteString -> IO a -> EitherT ErrorDesc m a +tryIOMsg msg = EitherT . liftIO . liftM (fmapL $ const msg) . + (E.try :: (IO a -> IO (Either E.SomeException a))) + +-- | Evaluate an error action and terminate process upon failure. +terminateOnFailure :: MonadIO m => ErrorDesc -> EitherT ErrorDesc m a -> m a +terminateOnFailure msg state = do + res <- runEitherT state + liftIO $ case res of + Left errorMessage -> do + B.hPutStrLn stderr $ msg <> ", error: " <> errorMessage + exitFailure + Right success -> return success + +-- | Sign an existing HTTP request with a temporary token. +makeSignedRequest :: RequestBuilder () -> AuthEnv IO Request +makeSignedRequest req = do + key <- lift $ liftM (setHeader "Cookie") ask + liftIO . buildRequest $ req >> key + +-- | Default HTTP request. +defaultRequest :: RequestBuilder () +defaultRequest = do + setHeader "User-Agent" programName + setHeader "Connection" "keep-alive" + +-- | Reestablish an existing connection. +-- Useful in order to avoid timeouts related to keep-alive. +reestablishConnection :: ConnEnv IO () +reestablishConnection = do + conn <- lift S.get + tryIOMsg "Failed to close connection" $ closeConnection conn + host' <- host <$> lift (lift S.get) + conn' <- tryIOMsg "Failed to reestablish connection" $ establishConnection host' + lift $ S.put conn' + +-- | Retrieve a publically available page, using HTTP GET. +retrievePublicPage :: B.ByteString -> ConnEnv IO B.ByteString +retrievePublicPage page = do + header <- tryIO . buildRequest $ http GET page >> defaultRequest + makeRequest header + +-- | Retrieve a page requiring authentication, using HTTP GET. +retrievePrivatePage :: B.ByteString -> AuthEnv IO B.ByteString +retrievePrivatePage page = do + header <- makeSignedRequest $ do + http GET page + defaultRequest + unWrapTrans $ makeRequest header + +-- | Make a HTTP request and retrieve the server response body. +makeRequest :: Request -> ConnEnv IO B.ByteString +makeRequest header = do + conn <- lift S.get + tryIO $ sendRequest conn header emptyBody + tryIO $ receiveResponse conn concatHandler + +-- | Extract correct temporary token from cookie header string. +extractSessionHeader :: B.ByteString -> Maybe B.ByteString +extractSessionHeader headerStr + | B.null match = Nothing + | otherwise = + case extractSessionHeader (B.tail match) of + Just match' -> Just match' + Nothing -> Just $ B.takeWhile (/= ';') match + where + (_, match) = B.breakSubstring "PHPSESSID" headerStr + +-- | Authenticate an existing connection, returns a temporary token. +-- Basically the API token is used to acquire a session-specific token. +authenticate :: ConnEnv IO B.ByteString +authenticate = do + conf <- lift $ lift S.get + + header <- tryIO . buildRequest $ do + http POST ("/" <> loginPage conf) + defaultRequest + setContentType "application/x-www-form-urlencoded" + + let formData = [("token", apiKey conf), ("user", user conf), ("script", "true")] + conn <- S.get + tryIO . sendRequest conn header $ encodedFormBody formData + + (headers, response) <- tryIO $ receiveResponse conn (\headers stream -> do + response <- readExactly (B.length loginSuccess) stream + return (headers, response)) + + tryAssert ("Login failure. Server returned: '" <> response <> "'") + (response == loginSuccess) + + noteT "Failed to parse login cookie" . hoistMaybe $ + getHeader headers "Set-Cookie" >>= extractSessionHeader + +-- | Retrieve problem ID of a Kattis problem. +retrieveProblemId :: KattisProblem -> ConnEnv IO Integer +retrieveProblemId (ProblemId id') = return id' +retrieveProblemId (ProblemName _) = undefined + +-- | Retrieve problem name of a Kattis problem. +retrieveProblemName :: KattisProblem -> ConnEnv IO B.ByteString +retrieveProblemName (ProblemId _) = undefined +retrieveProblemName (ProblemName name) = return name diff --git a/katt-tests/src/TestSourceHandler.hs b/katt-tests/src/TestSourceHandler.hs new file mode 100644 --- /dev/null +++ b/katt-tests/src/TestSourceHandler.hs @@ -0,0 +1,56 @@ +module Main where + +import Control.Applicative ((<$>)) +import Control.Monad +import Data.List (subsequences) +import Data.Monoid ((<>)) +import System.Exit (exitFailure, exitSuccess) +import System.Directory (getDirectoryContents) +import System.IO +import Utils.Katt.SourceHandler +import Utils.Katt.Utils + +main :: IO () +main = do + res <- verifyLanguages + if res then exitSuccess else exitFailure + +-- Given a set of source files, categorized into folders corresponding to all supported languages. +-- Test the following things: +-- (1) That the corresponding languages are actually identified correctly, also when intermixed. +-- (2) That all main method classes are identified correctly in the case of java and python + +languages :: [(KattisLanguage, String)] +languages = [(LangCplusplus, "c++"), (LangC, "c"), (LangJava, "java")] + +testDir :: String +testDir = "katt-tests/data/sample_submissions/" + +verifyLanguages :: IO Bool +verifyLanguages = and <$> mapM (\lang -> liftM2 (&&) (verifyLanguage lang) (verifyMain lang)) languages + where + verifyMain info@(LangJava, folder) = do + tests <- getFileNamesSimple $ testDir <> folder + res <- mapM (\test -> findMainClass ([test], fst info)) tests + if Nothing `notElem` res then return True else do + hPutStrLn stderr $ "Failed to verify SourceHandler: main class for language " <> show (fst info) + return False + + verifyMain _ = return True + + verifyLanguage (identifier, folder)= do + tests <- getFileNames $ testDir <> folder + let res = map determineLanguage tests + if Nothing `notElem` res then return True else do + hPutStrLn stderr $ "Failed to verify SourceHandler: language " <> show identifier + return False + + filterNonFiles = filter (`notElem` [".", ".."]) + addFolder folder = map ((folder <> "/") <>) + + getFileNames folder = map (addFolder folder) <$> files + where files = map filterNonFiles . drop 1 . subsequences + <$> getDirectoryContents folder + + getFileNamesSimple folder = addFolder folder <$> files + where files = filterNonFiles <$> getDirectoryContents folder diff --git a/katt.cabal b/katt.cabal --- a/katt.cabal +++ b/katt.cabal @@ -1,5 +1,5 @@ name: katt -version: 0.1.0.0 +version: 0.2.0.0 stability: experimental synopsis: Client for the Kattis judge system. @@ -31,7 +31,17 @@ . Please note that the beta release is limited to C, C++ and Java. It also only supports running on unix. + . + Changes since last release: + . + * Fix issues related to to new keep-alive handling + . + * New test suite + . + * Confirmed working with open kattis (www.kattis.com) + . + homepage: https://github.com/davnils/katt bug-reports: https://github.com/davnils/katt/issues @@ -46,20 +56,21 @@ build-type: Simple cabal-version: >=1.8 +-- Support building on earlier GHC, at least 7.4.1 and 7.4.2. +-- The current solution does not scale very well since dependencies +-- are listed under each section (lib, exe, test1, test2, ..) +-- see https://github.com/haskell/cabal/issues/417 +-- and the related discussion. -executable katt - hs-source-dirs: src - main-is: Main.hs - other-modules: Init, Upload, Configuration, Utils, SourceHandler - ghc-options: -O2 -threaded -Wall +library + hs-source-dirs: katt-lib/src + exposed-modules: Utils.Katt.Configuration, + Utils.Katt.Init, + Utils.Katt.SourceHandler, + Utils.Katt.Upload, + Utils.Katt.Utils - -- Support building on earlier GHC, at least 7.4.1 and 7.4.2 - if impl(ghc <= 7.4.1) - build-depends: - regex-posix == 0.95.1 - else - build-depends: - regex-posix == 0.95.* + ghc-options: -Wall if impl(ghc <= 7.4.2) build-depends: @@ -81,11 +92,74 @@ http-streams == 0.6.*, HsOpenSSL >= 0.10.3 && < 0.11, io-streams, - mtl == 2.1.*, + mtl >= 2.0 && < 2.2, parsec == 3.1.*, unix == 2.6.*, url == 2.1.*, zip-archive == 0.1.* + +executable katt + hs-source-dirs: katt-cli/src + main-is: Main.hs + ghc-options: -O2 -threaded -Wall + + if impl(ghc <= 7.4.2) + build-depends: + base == 4.5.*, + bytestring >= 0.9.2.1 + else + build-depends: + base == 4.6.*, + bytestring == 0.10.* + + build-depends: + http-streams == 0.6.*, + HsOpenSSL >= 0.10.3 && < 0.11, + katt, + mtl >= 2.0 && < 2.2 + +-- Test-Suite test-katt-init +-- type: exitcode-stdio-1.0 +-- hs-source-dirs: katt-tests/src +-- main-is: TestInit.hs +-- ghc-options: -O2 -threaded -Wall +-- +-- if impl(ghc <= 7.4.2) +-- build-depends: +-- base == 4.5.*, +-- bytestring >= 0.9.2.1 +-- else +-- build-depends: +-- base == 4.6.*, +-- bytestring == 0.10.* +-- +-- build-depends: +-- http-streams == 0.6.*, +-- HsOpenSSL >= 0.10.3 && < 0.11, +-- katt, +-- mtl >= 2.0 && < 2.2 + +Test-Suite test-katt-sourcehandler + type: exitcode-stdio-1.0 + hs-source-dirs: katt-tests/src + main-is: TestSourceHandler.hs + ghc-options: -O2 -threaded -Wall + + if impl(ghc <= 7.4.2) + build-depends: + base == 4.5.*, + bytestring >= 0.9.2.1 + else + build-depends: + base == 4.6.*, + bytestring == 0.10.* + + build-depends: + directory == 1.2.*, + http-streams == 0.6.*, + HsOpenSSL >= 0.10.3 && < 0.11, + katt, + mtl >= 2.0 && < 2.2 source-repository head type: git diff --git a/src/Configuration.hs b/src/Configuration.hs deleted file mode 100644 --- a/src/Configuration.hs +++ /dev/null @@ -1,119 +0,0 @@ -{-# Language OverloadedStrings, NoMonomorphismRestriction #-} - --------------------------------------------------------------------- --- | --- Module : Configuration --- --- Implements loading and saving of global and local configurations. --- All configurations are stored in the 'ConfigFile' format, which is --- fully compatible with the official Kattis configuration file. --- --- The global configuration file corresponds to /kattisrc/, which holds --- information regarding authentication and hosts. --- --- The local configuration holds project-specific information and --- is created by the 'Init' submodule. --- Currently only the problem name is stored. - -module Configuration (loadGlobalConfig, projectConfigExists, loadProjectConfig, saveProjectConfig) where - -import Control.Error hiding (tryIO) -import Control.Monad -import qualified Control.Monad.State as S -import Control.Monad.Trans (liftIO, lift) -import qualified Data.ByteString.Char8 as B -import Data.ConfigFile -import Data.Monoid ((<>)) -import qualified Network.URL as U -import System.Directory (getHomeDirectory) -import System.IO -import System.IO.Error (catchIOError) -import Utils - --- | Path to global configuration file, relative home directory. -globalConfigFile :: FilePath -globalConfigFile = ".kattisrc" - --- | Path to project-specific (local) configuration file. -projectConfigFile :: FilePath -projectConfigFile = B.unpack $ configDir <> "/" <> "config" - --- | Serialize error description into bytestring. -convertErrorDesc :: (Show a) => (a, String) -> B.ByteString -convertErrorDesc (errorData, str) = B.pack (show errorData) <> B.pack str - --- | Retrieve a field from the configuration state using a key and section, --- possibly failing. -get' :: (Monad m, Get_C r) => ConfigParser -> SectionSpec -> String -> EitherT B.ByteString m r -get' conf section key = fmapLT - (const . B.pack $ "Failed to parse " <> key <> " field") - (get conf section key) - --- | Load global configuration file and parse the configuration state. --- Ensures that all fields are present and validates the URLs. -loadGlobalConfig :: IO (Either ErrorDesc ConfigState) -loadGlobalConfig = runEitherT $ do - home <- tryIO getHomeDirectory - let filePath = home <> "/" <> globalConfigFile - - fileHandle <- tryIOMsg ("Failed to open " <> B.pack filePath) $ - openFile filePath ReadMode - conf <- fmapLT convertErrorDesc $ join . liftIO $ readhandle emptyCP fileHandle - - user' <- get' conf "user" "username" - apiKey' <- get' conf "user" "token" - - loginURL <- get' conf "kattis" "loginurl" - loginParsed <- extract "Failed to parse loginurl field" loginURL - - submitURL <- get' conf "kattis" "submissionurl" - submitParsed <- extract "Failed to parse submissionurl field" submitURL - - host' <- parseHost loginParsed - - tryIOMsg "Failed to close configuration file handle" $ hClose fileHandle - - return $ ConfigState - (B.pack user') - (B.pack apiKey') - (B.pack $ "https://" <> host') - (B.pack $ U.url_path loginParsed) - (B.pack $ U.url_path submitParsed) - Nothing - - where - extract msg = noteT msg . hoistMaybe . U.importURL - parseHost (U.URL (U.Absolute host') _ _) = return $ U.host host' - parseHost _ = left "Invalid URL format" - --- | Check if a project-specific configuration file exists and can be read. -projectConfigExists :: IO Bool -projectConfigExists = catchIOError open . const $ return False - where - open = withFile projectConfigFile ReadMode . const $ return True - --- | Load a project-specific configuration based on the current directory. -loadProjectConfig :: ConfigEnv IO () -loadProjectConfig = do - conf <- fmapLT convertErrorDesc $ join . liftIO $ readfile emptyCP projectConfigFile - problem <- get' conf "problem" "problemname" - lift . S.modify $ \s -> s { project = Just . ProblemName $ B.pack problem} - --- | Save a project-specific configuration file to disk. -saveProjectConfig :: ConnEnv IO () -saveProjectConfig = do - project' <- lift . lift $ S.gets project - state <- noteT "Tried to save an empty project configuration." . hoistMaybe $ project' - problemName <- retrieveProblemName state - serialized <- serialize problemName - tryIOMsg (B.pack $ - "Failed to save project configuration file (path: " - <> projectConfigFile <> ")") $ - writeFile projectConfigFile (to_string serialized) - - where - serialize problemName = EitherT . return . fmapL convertErrorDesc $ do - let conf = emptyCP - conf' <- add_section conf "problem" - conf'' <- add_section conf' "submissions" - set conf'' "problem" "problemname" $ B.unpack problemName diff --git a/src/Init.hs b/src/Init.hs deleted file mode 100644 --- a/src/Init.hs +++ /dev/null @@ -1,197 +0,0 @@ -{-# Language OverloadedStrings, ScopedTypeVariables, - NoMonomorphismRestriction #-} - --------------------------------------------------------------------- --- | --- Module : Init --- --- Init submodule providing initialization of problems --- and entire problem sessions. --- --- Problems are initialized by creating a directory, configuration file, --- and optionally downloading all test files available. --- Both zip-based test data and embedded HTML tables are supported. --- --- Problem sessions are initialized by parsing the list of problems and --- initializing each problem separately. - -module Init (initializeProblem, initializeSession) where - -import Control.Applicative ((<$>), (<*)) -import Codec.Archive.Zip -import Control.Arrow ((***)) -import qualified Control.Monad.State as S -import qualified Configuration as C -import Control.Error hiding (tryIO) -import qualified Control.Exception as E -import Control.Monad.Reader -import qualified Data.ByteString.Char8 as B -import qualified Data.ByteString.Lazy.Char8 as BL -import Data.Foldable (fold) -import Data.List (isSuffixOf, nub) -import Data.Monoid ((<>)) -import System.Directory -import System.IO (stderr) -import Text.Parsec hiding (token) -import Text.Parsec.ByteString -import Utils - --- | Parsed test cases associated with a problem. -type TestContent = [(B.ByteString, B.ByteString)] - --- | Possible test case scenarios. -data TestParser - -- | No tests available. - = NoTestsAvailable - -- | Test content available in zip file, given as URL. - | TestAddress B.ByteString - -- | Embedded test content. - | TestContents TestContent - deriving Show - --- | Parse the possible different test file cases, given the problem page. --- Any zip download links are preferred over embedded test data. -parseProblemPage :: B.ByteString -> TestParser -parseProblemPage contents = - case res of - Left _ -> NoTestsAvailable - Right test -> test - where res = parse (try parseAddress <|> parseEmbedded) "Test parser" contents - --- | Try to parse a download URL from the supplied page data. -parseAddress :: GenParser Char st TestParser -parseAddress = do - void $ manyTill anyChar (try $ startLink >> lookAhead endParser) - TestAddress . B.cons '/' . B.pack <$> endParser - - where - startLink = string " tests - where - sp = skipMany $ space <|> newline <|> tab - beginTag tag = void $ char '<' >> sp >> string tag >> sp >> char '>' - endTag tag = void $ char '<' >> sp >> char '/' >> string tag >> sp >> char '>' - htmlTag tag p = do - sp >> beginTag tag >> sp - manyTill p $ try $ endTag tag - - tr = htmlTag "tr" - td = htmlTag "td" - pre = htmlTag "pre" - - tests = manyTill anyChar (lookAhead startTable) >> endBy1 testTable sp - - startTable = void . try $ string "" - endTable = void $ string "
" - - testTable = do - startTable - inner <- tableBody - sp >> endTable - return inner - - tableBody = do - void $ tr anyChar - try (fold <$> tr testCase) <* sp - - innerTestData = do - sp - B.pack <$> pre anyChar <* sp - - testData = liftM fold $ td innerTestData <* sp - testCase = liftM2 (,) testData testData - --- | Retrieve the zip archive located at the specified URL and unzip the contents. --- Matches input and output file pairs, producing a list of tuples. -downloadTestArchive :: B.ByteString -> ConnEnv IO TestContent -downloadTestArchive url = do - zipFile <- BL.fromChunks . return <$> retrievePublicPage url - zipEntries <- tryIOMsg "Failed to unpack zip file: corrupt archive" $ - E.evaluate (zEntries $ toArchive zipFile) - - let filterFiles suffix = filter (isSuffixOf suffix . eRelativePath) zipEntries - inFiles = filterFiles inputTestExtension - outFiles = filterFiles outputTestExtension - - tryAssert "Failed to unpack zip file: no test files found" $ - not (null zipEntries) - tryAssert "Failed to unpack zip file: input and reference count doesn't match" $ - length inFiles == length outFiles - - return $ zipWith (curry convertEntry) inFiles outFiles - where - convertEntry = getData *** getData - getData = fold . BL.toChunks . fromEntry - --- | Retrieve test cases, which fall into either one of the three categories. -retrieveTestFiles :: KattisProblem -> ConnEnv IO TestContent -retrieveTestFiles problem = do - problemName <- retrieveProblemName problem - problemPage <- retrievePublicPage $ problemAddress <> problemName - - case parseProblemPage problemPage of - NoTestsAvailable -> do - tryIO $ B.hPutStrLn stderr "No tests available" - return [] - TestAddress addr -> downloadTestArchive addr - TestContents list -> return list - --- | Page listing all problems associated with a problem session, relative 'Utils.host'. -sessionPage :: B.ByteString -sessionPage = "/standings/?sid=" - --- | Parse a problem session page, locating all the associated problem names. -parseProblemList :: GenParser Char st [KattisProblem] -parseProblemList = skip >> endBy1 tag skip - where - beginLink = string " ProblemSession -> ConnEnv IO () -initializeSession retrieveTests session = do - contents <- retrievePublicPage $ sessionPage <> (B.pack $ show session) - problems <- nub <$> (EitherT . return . fmapL (B.pack . show) $ parse' contents) - mapM_ (\problem -> initializeProblem True retrieveTests problem >> restoreDir) problems - where - parse' contents = parse (parseProblemList) "Problem list parser" contents - restoreDir = liftIO $ setCurrentDirectory ".." - -- TODO: restore to previously used directory - --- | Given a problem identifier, setup directory structures and --- optionally download test cases. -initializeProblem :: Bool -> Bool -> KattisProblem -> ConnEnv IO () -initializeProblem mkDir retrieveTests problem = do - liftIO . putStrLn $ "Initializing problem: " <> show problem - problemName <- retrieveProblemName problem - tryIO . when mkDir $ do - createDirectoryIfMissing False (B.unpack problemName) - setCurrentDirectory (B.unpack problemName) - - tryIO $ createDirectoryIfMissing False (B.unpack configDir) - - fileExists <- liftIO C.projectConfigExists - tryAssert - "Project configuration file already exists, please remove it in order to continue." - (not fileExists) - - lift . lift . S.modify $ \s -> s { project = Just $ ProblemName problemName } - C.saveProjectConfig - - when retrieveTests $ do - tryIO $ createDirectory testFolder - files <- zip [1..] <$> retrieveTestFiles problem - mapM_ (\(n :: Integer, (input, output)) -> do - let fileName = testFolder <> "/" <> B.unpack problemName <> "-" <> show n - tryIO $ B.writeFile (fileName <> inputTestExtension) input - tryIO $ B.writeFile (fileName <> outputTestExtension) output) - files diff --git a/src/Main.hs b/src/Main.hs deleted file mode 100644 --- a/src/Main.hs +++ /dev/null @@ -1,78 +0,0 @@ -{-# Language OverloadedStrings #-} - --------------------------------------------------------------------- --- | --- Module : Main --- --- Entry point of the program. --- --- Begins by locating a global configuration file, and upon success --- parses the given arguments and executes the corresponding submodule. --- - -module Main(main) where - -import qualified Configuration as C -import Control.Monad.State -import qualified Data.ByteString.Char8 as B -import Data.Monoid ((<>)) -import Init -import Network.Http.Client -import OpenSSL (withOpenSSL) -import System.Environment -import System.Exit (exitFailure) -import Upload -import Utils - --- | Main loads the global config and runs argument parsing. -main :: IO () -main = do - conf <- C.loadGlobalConfig - conf' <- case conf of - Left err -> do - B.putStrLn $ "Kattis configuration error: " <> err - printHelp - exitFailure - Right c -> return c - - withOpenSSL $ parseArgs conf' - --- | Given some configuration state, parse arguments and --- run the appropiate submodule. --- Output help text upon failure to parse arguments. -parseArgs :: ConfigState -> IO () -parseArgs conf = getArgs >>= parse - where - parse :: [String] -> IO () - parse ("init" : problem : []) = withConn conf . initializeProblem True True . ProblemName $ B.pack problem - parse ("init-session" : session : []) = withConn conf . initializeSession True $ read session - parse ("submit" : filterList) = withConn conf $ makeSubmission filterList - parse _ = printHelp - --- | Print help text. -printHelp :: IO () -printHelp = putStrLn $ - "The following commands are available:\n\n" <> - "init \n" <> - " Create the corresponding directory and download any available tests.\n\n" <> - "init-session \n" <> - " Initialize all problems associated to the problem session, given as an integer id.\n\n" <> - "submit [+add_file] [-skip_file]\n" <> - " Make a submission using the problem name read from a local config.\n" <> - " Defaults to recursively including all source and header files that can be found.\n" <> - " Use the optional filter arguments to include or exclude files.\n\n" <> - "Note that you will need a valid configuration file (placed in ~/.kattisrc), such as:\n" <> - "https://kth.kattis.scrool.se/download/kattisrc\n" - --- | Given some action, initiate a connection and run it. --- Connections are layered using StateT since they may be reestablished. -withConn :: ConfigState -> ConnEnv IO a -> IO a -withConn conf action = do - B.putStrLn $ "Connecting to host: " <> host conf - conn <- establishConnection (host conf) - ((res, conn'), _) <- runStateT (withConf conn) conf - closeConnection conn' - return res - - where - withConf = runStateT (terminateOnFailure "Failed to run command" action) diff --git a/src/SourceHandler.hs b/src/SourceHandler.hs deleted file mode 100644 --- a/src/SourceHandler.hs +++ /dev/null @@ -1,114 +0,0 @@ -{-# Language OverloadedStrings #-} - --------------------------------------------------------------------- --- | --- Module : SourceHandler --- --- Provides searching of source code files and language identification. --- --- Language identification is required in order to detect any --- inconsistencies (e.g. combining Java and C), and to tag submissions. --- --- Java also requires identifying which file provides the main method. - -module SourceHandler (parseFilter, findFiles, determineLanguage, findMainClass, languageKattisName, languageContentType) where - -import Control.Applicative ((<$>)) -import Control.Arrow ((***)) -import Control.Monad -import qualified Data.ByteString.Char8 as B -import Data.List -import qualified Data.Set as Set -import System.Directory -import System.FilePath (takeBaseName, takeExtension) -import Text.Parsec -import Text.Parsec.ByteString -import Utils - --- | All supported source file extensions, per language. -supported :: KattisLanguage -> Set.Set FilePath -supported LangCplusplus = Set.fromList [".cc", ".cpp", ".hpp", ".h"] -supported LangC = Set.fromList [".c", ".h"] -supported LangJava = Set.fromList [".java"] - --- | Parse an argument list from the +file1 -file2 style into --- two lists of file paths (included and ignored files). -parseFilter :: [String] -> Maybe ([FilePath], [FilePath]) -parseFilter input = (filter' *** filter') <$> mapAndUnzipM go input - where - go ('+' : file) = Just (file, "") - go ('-' : file) = Just ("", file) - go _ = Nothing - filter' = filter (not . null) - --- | Locate all source files recursively from the current directory. -findFiles :: IO [FilePath] -findFiles = explore "" "." - where - explore prefix dir = do - contents <- (\\ [".", ".."]) <$> getDirectoryContents dir - let withPrefix = map (prefix++) contents - - dirs <- filterM doesDirectoryExist withPrefix - let sourceFiles = filter isValidSourceFile (withPrefix \\ dirs) - nextDepth <- mapM exploreDir dirs - return $ sourceFiles ++ concat nextDepth - - isValidSourceFile file = any (`isSuffixOf` file) - (Set.toList . Set.unions $ map supported [LangCplusplus, LangC, LangJava]) - exploreDir dir = explore (dir ++ "/") dir - --- | Determine source code language by studying file extensions. --- There is an implicit priority ordering, since C is a subset of C++. -determineLanguage :: [FilePath] -> Maybe KattisLanguage -determineLanguage files - | is LangC = Just LangC - | is LangCplusplus = Just LangCplusplus - | is LangJava = Just LangJava - | otherwise = Nothing - where - fileSet = Set.fromList $ map takeExtension files - is lang = fileSet `Set.isSubsetOf` (supported lang) - --- | Locate main class based on source file contents. --- C++ and C solutions do not need to be specified, returns an empty string. --- --- In the Java case all souce code files are parsed. --- All occurences of a /main/ method defined with /public static void/ are located. --- --- Will return 'Data.Maybe.Nothing' if result is ambiguous. -findMainClass :: ([FilePath], KattisLanguage) -> IO (Maybe FilePath) -findMainClass ([], _) = return Nothing -findMainClass (_, LangCplusplus) = return $ Just "" -findMainClass (_, LangC) = return $ Just "" -findMainClass (files, LangJava) = survey <$> filterM containsMain files - where - containsMain file = do - parseResult <- parseFromFile mainParser file - case parseResult of - Right _ -> return True - Left _ -> return False - - mainParser = manyTill - (lineComment <|> blockComment <|> stringData <|> void anyChar) - mainFunc - blockComment = void $ string "/*" >> manyTill anyChar (try $ string "*/") - lineComment = void . try $ string "//" >> manyTill anyChar newline - stringData = void $ char '"' >> manyTill anyChar (char '"') - mainFunc = try $ mapM_ keyWord ["public", "static", "void", "main"] - keyWord str = void $ string str >> spaces - - survey [singleton] = Just $ takeBaseName singleton - survey _ = Nothing - --- | Determine content type of submission language. -languageContentType :: KattisLanguage -> B.ByteString -languageContentType LangCplusplus = "text/x-c++src" -languageContentType LangJava = "text/x-c++src" -languageContentType LangC = "text/x-c++src" - --- | Determine Kattis language string identifier. -languageKattisName :: KattisLanguage -> B.ByteString -languageKattisName LangCplusplus = "C++" -languageKattisName LangJava = "Java" -languageKattisName LangC = "C" diff --git a/src/Upload.hs b/src/Upload.hs deleted file mode 100644 --- a/src/Upload.hs +++ /dev/null @@ -1,314 +0,0 @@ -{-# Language OverloadedStrings, ScopedTypeVariables #-} - --------------------------------------------------------------------- --- | --- Module : Upload --- --- Upload submodule providing submissions of solutions and parsing of results. --- --- A submission is done by including all recursively found files and filtering --- using a file filter given as an argument. --- This is followed by polling for a submission result until some final --- submission state has been reached (e.g. accepted). --- --- Currently multipart data upload is implemented since https-streams --- (the HTTP client being used) does not support it (yet?). - -module Upload (makeSubmission) where - -import Control.Applicative ((<$>)) -import Blaze.ByteString.Builder (fromByteString) -import qualified 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 SourceHandler -import System.IO.Streams (write) -import Text.Parsec hiding (token) -import Text.Parsec.ByteString -import Text.Regex.Posix -import Utils - --- | Line separator used in HTTP headers. -crlf :: B.ByteString -crlf = "\r\n" - --- | Multipart field consisting of an option or file. -data MultiPartField - -- | Option built using a list of assignments and a payload. - = Option [B.ByteString] B.ByteString - -- | File to submitted, path given. - | File FilePath - --- | Serialize a chunk based on a file to be submitted. -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, "\""]] - --- | Serialize a chunk based on an option. -buildChunk _ (Option fields payload) = return $ B.intercalate crlf [headerLine, "", payload, ""] - where - headerLine = B.intercalate "; " fieldList - fieldList = "Content-Disposition: form-data" : fields - --- | Submission page URL, relative 'Utils.host', from which specific submission can be requested. -submissionPage :: B.ByteString -submissionPage = "submission" - --- | Possible states of a submission, with unknowns being grouped into 'Other'. -data SubmissionState - -- | Submission is queued. - = Queued - -- | Submission is compiling. - | Compiling - -- | Submission is running. - | Running - -- | Wrong answer. - | WrongAnswer - -- | Time limit exceeded. - | TimeLimitExceeded - -- | Submission was accepted (only success state). - | Accepted - -- | Compile error. - | CompileError - -- | Run time error. - | RunTimeError - -- | Some other, unmatched error code. Only used when parsing fails. - | Other - deriving (Eq, Show) - --- | Possible states of a single test case, i.e. an (input, output) data pair. -data TestCase - -- | Test case passed. - = TestPassed - -- | Test case failed (state /= Accepted) - | TestFailed - -- | Test case has not been executed. - | NotTested - deriving (Eq, Show) - --- | Check if a given state is final, i.e. won't transition into some other. --- Note that 'Other' is listed as final. -finalSubmissionState :: SubmissionState -> Bool -finalSubmissionState s = elem s - [WrongAnswer, TimeLimitExceeded, Accepted, CompileError, RunTimeError, Other] - --- | Make a submission of the project in the working directory. --- Accepts a list of filters on the form /+file1 -file2 ../, which are --- taken into account when locating all the source files. --- /+file/ implies adding the specified file. --- /-file/ implies removing the specified file. --- --- In addition to the filters, all recursively found source code files --- will be included in the submission. -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) - - -- Locate all source files, filter based on filter list. - files <- tryIOMsg "Failed to locate source files" findFiles - let adjusted = adjust (parseFilter filterArguments) files - - liftIO $ mapM_ (putStrLn . ("Adding file: "++)) adjusted - - -- Authenticate, submit files, and retrieve submission id. - token <- authenticate - - submission <- EitherT $ runReaderT - (runEitherT $ submitSolution (problem, adjusted)) token - - tryIO . putStrLn $ "Made submission: " <> show submission - tryIO $ threadDelay initialTimeout - reestablishConnection - - -- Poll submission page until completion. - token' <- authenticate - EitherT $ runReaderT - (runEitherT $ checkSubmission submission) token' - - where - adjust Nothing files = files - adjust (Just (add, sub)) files = union (files \\ sub) add - - -- Initial timeout before requesting updates is 2 s. - initialTimeout = 2000000 - --- | Poll kattis for updates on a submission. --- This function returns when the submission has reached one of the final states. --- TODO: Consider exponential back-off and timeout -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 - -- Default poll interval is 1 s. - interval = 1000000 - --- | Parse the supplied submission page into: --- (1) Current submission state --- (2) Status of all test cases -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 - --- | String separator parser. -strSep :: GenParser Char st () -strSep = void (char '\'' <|> char '"') - --- | End-of-tag parser, ignores everything up to the end of the current tag. -endTag :: GenParser Char st () -endTag = void $ manyTill anyChar (char '>') - --- | Parse the submission status field, beginning from any offset in the page data. -parseStatus :: GenParser Char st SubmissionState -parseStatus = skip >> status - where - beginStatus = do - void $ string "> strSep >> endTag - void $ string "> tests - where - beginTests = do - void $ string "
> strSep - endTag - - -- Locate surrounding div tag. - skip = manyTill anyChar (void (try beginTests) <|> eof) - - -- Parse all test cases. - tests = many testCase - - -- Each test case is basically ... - -- where a missing class attribute implies that it hasn't been executed. - testCase = do - void . try $ string "" - fromMaybe (return NotTested) (mapResult <$> classResult) - - mapResult "accepted" = return TestPassed - mapResult "rejected" = return TestFailed - mapResult _ = parserZero - --- | Print the result of a submission. --- Will also take care of the special case when no test cases were parsed. -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 - - --- | Submit a solution, given problem name and source code files. -submitSolution :: Submission -> AuthEnv IO SubmissionId -submitSolution (problem, files) = do - -- Determine language in submission. - 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) - - -- Build HTTP headers and form. - 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 - - -- Send request. - 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 - ) - - -- Receive server response. - reply <- tryIO $ receiveResponse conn concatHandler - tryRead "Failed to parse submission id from server" . B.unpack $ reply =~ ("[0-9]+" :: B.ByteString) diff --git a/src/Utils.hs b/src/Utils.hs deleted file mode 100644 --- a/src/Utils.hs +++ /dev/null @@ -1,229 +0,0 @@ -{-# Language OverloadedStrings, ScopedTypeVariables, - NoMonomorphismRestriction #-} - --------------------------------------------------------------------- --- | --- Module : Utils --- --- Contains shared type declarations and various utility functions. --- - -module Utils where - -import Control.Applicative ((<$>)) -import Control.Error hiding (tryIO) -import qualified Control.Exception as E -import Control.Monad.Reader -import qualified Control.Monad.State as S -import qualified Data.ByteString.Char8 as B -import Data.Monoid ((<>)) -import Network.Http.Client -import System.Exit (exitFailure) -import System.IO (stderr) -import System.IO.Streams (readExactly) - --- | Configuration layer consisting of configuration state. -type ConfigEnvInternal m = S.StateT ConfigState m --- | Configuration layer wrapped with error handling. -type ConfigEnv m = EitherT ErrorDesc (ConfigEnvInternal m) - --- | Connection layer with connection state layered on the configuration layer. -type ConnEnvInternal m = S.StateT Connection (ConfigEnvInternal m) --- | Connection layer wrapped with error handling. -type ConnEnv m = EitherT ErrorDesc (ConnEnvInternal m) - --- | Authentication layer with token state and error handling, --- wrapping the connection layer. -type AuthEnv m = EitherT ErrorDesc (ReaderT B.ByteString (ConnEnvInternal m)) - --- | Submissions consist of a problem identifier and a set of file paths. -type Submission = (KattisProblem, [FilePath]) - --- | Error description alias. -type ErrorDesc = B.ByteString - --- | Submissions are identified with an integer id. -type SubmissionId = Integer --- --- | Problem sessions are identified with an integer id. -type ProblemSession = Integer - --- | Project-specific state consists of the problem name. -type ProjectState = (KattisProblem) - --- | Global configuration, initialized from the /.kattisrc/ file. -data ConfigState = - ConfigState { - -- | Username. - user :: B.ByteString, - -- | API token (hash). - apiKey :: B.ByteString, - -- | Host to be considered as service. - host :: B.ByteString, - -- | URL to login page, relative 'host'. - loginPage :: B.ByteString, - -- | URL to submit page, relative 'host'. - submitPage :: B.ByteString, - -- | Project-specific state, optionally loaded. - project :: Maybe ProjectState - } - deriving Show - --- | A Kattis problem. -data KattisProblem - -- | Problem ID, unique. - = ProblemId Integer - -- | Associated name of the problem. - | ProblemName B.ByteString - deriving (Eq, Show) - --- | Language used in submission. -data KattisLanguage - -- | C++. - = LangCplusplus - -- | Java. - | LangJava - -- | C. - | LangC - deriving (Eq, Show) - --- | Server response indicating successful login. -loginSuccess :: B.ByteString -loginSuccess = "Login successful" - --- | Extension of input test files. -inputTestExtension :: FilePath -inputTestExtension = ".in" - --- | Extension of reference ouput test files. -outputTestExtension :: FilePath -outputTestExtension = ".ans" - --- | Name of this program. -programName :: B.ByteString -programName = "katt" - --- | Relative path to project-specific configuration directory. -configDir :: B.ByteString -configDir = "." <> programName - --- | Relative path to folder containing tests. -testFolder :: FilePath -testFolder = "tests" - --- | URL to page with problem information, relative to 'host'. -problemAddress :: B.ByteString -problemAddress = "/problems/" - --- | Lift some error monad one layer. -unWrapTrans :: (Monad m, MonadTrans t) => EitherT e m a -> EitherT e (t m) a -unWrapTrans = EitherT . lift . runEitherT - --- | Execute an IO action and catch any exceptions. -tryIO :: MonadIO m => IO a -> EitherT ErrorDesc m a -tryIO = EitherT . liftIO . liftM (fmapL (B.pack . show)) . - (E.try :: (IO a -> IO (Either E.SomeException a))) - --- | Execute an IO action and catch any exceptions, tagged with description. -tryIOMsg :: MonadIO m => B.ByteString -> IO a -> EitherT ErrorDesc m a -tryIOMsg msg = EitherT . liftIO . liftM (fmapL $ const msg) . - (E.try :: (IO a -> IO (Either E.SomeException a))) - --- | Evaluate an error action and terminate process upon failure. -terminateOnFailure :: MonadIO m => ErrorDesc -> EitherT ErrorDesc m a -> m a -terminateOnFailure msg state = do - res <- runEitherT state - liftIO $ case res of - Left errorMessage -> do - B.hPutStrLn stderr $ msg <> ", error: " <> errorMessage - exitFailure - Right success -> return success - --- | Sign an existing HTTP request with a temporary token. -makeSignedRequest :: RequestBuilder () -> AuthEnv IO Request -makeSignedRequest req = do - key <- lift $ liftM (setHeader "Cookie") ask - liftIO . buildRequest $ req >> key - --- | Default HTTP request. -defaultRequest :: RequestBuilder () -defaultRequest = do - setHeader "User-Agent" programName - setHeader "Connection" "keep-alive" - --- | Reestablish an existing connection. --- Useful in order to avoid timeouts related to keep-alive. -reestablishConnection :: ConnEnv IO () -reestablishConnection = do - conn <- lift S.get - tryIOMsg "Failed to close connection" $ closeConnection conn - host' <- host <$> lift (lift S.get) - conn' <- tryIOMsg "Failed to reestablish connection" $ establishConnection host' - lift $ S.put conn' - --- | Retrieve a publically available page, using HTTP GET. -retrievePublicPage :: B.ByteString -> ConnEnv IO B.ByteString -retrievePublicPage page = do - header <- tryIO . buildRequest $ http GET page >> defaultRequest - makeRequest header - --- | Retrieve a page requiring authentication, using HTTP GET. -retrievePrivatePage :: B.ByteString -> AuthEnv IO B.ByteString -retrievePrivatePage page = do - header <- makeSignedRequest $ do - http GET page - defaultRequest - unWrapTrans $ makeRequest header - --- | Make a HTTP request and retrieve the server response body. -makeRequest :: Request -> ConnEnv IO B.ByteString -makeRequest header = do - conn <- lift S.get - tryIO $ sendRequest conn header emptyBody - tryIO $ receiveResponse conn concatHandler - --- | Extract correct temporary token from cookie header string. -extractSessionHeader :: B.ByteString -> Maybe B.ByteString -extractSessionHeader headerStr - | B.null match = Nothing - | otherwise = - case extractSessionHeader (B.tail match) of - Just match' -> Just match' - Nothing -> Just $ B.takeWhile (/= ';') match - where - (_, match) = B.breakSubstring "PHPSESSID" headerStr - --- | Authenticate an existing connection, returns a temporary token. --- Basically the API token is used to acquire a session-specific token. -authenticate :: ConnEnv IO B.ByteString -authenticate = do - conf <- lift $ lift S.get - - header <- tryIO . buildRequest $ do - http POST ("/" <> loginPage conf) - defaultRequest - setContentType "application/x-www-form-urlencoded" - - let formData = [("token", apiKey conf), ("user", user conf), ("script", "true")] - conn <- S.get - tryIO . sendRequest conn header $ encodedFormBody formData - - (headers, response) <- tryIO $ receiveResponse conn (\headers stream -> do - response <- readExactly (B.length loginSuccess) stream - return (headers, response)) - - tryAssert ("Login failure. Server returned: '" <> response <> "'") - (response == loginSuccess) - - noteT "Failed to parse login cookie" . hoistMaybe $ - getHeader headers "Set-Cookie" >>= extractSessionHeader - --- | Retrieve problem ID of a Kattis problem. -retrieveProblemId :: KattisProblem -> ConnEnv IO Integer -retrieveProblemId (ProblemId id') = return id' -retrieveProblemId (ProblemName _) = undefined - --- | Retrieve problem name of a Kattis problem. -retrieveProblemName :: KattisProblem -> ConnEnv IO B.ByteString -retrieveProblemName (ProblemId _) = undefined -retrieveProblemName (ProblemName name) = return name