katt 0.1.0.0 → 0.2.0.0

raw patch · 14 files changed

+1220/−1065 lines, 14 filesdep +kattdep −regex-posixdep ~basedep ~bytestringdep ~mtl

Dependencies added: katt

Dependencies removed: regex-posix

Dependency ranges changed: base, bytestring, mtl

Files

• katt-cli/src/Main.hs +78/−0
• katt-lib/src/Utils/Katt/Configuration.hs +121/−0
• katt-lib/src/Utils/Katt/Init.hs +205/−0
• katt-lib/src/Utils/Katt/SourceHandler.hs +116/−0
• katt-lib/src/Utils/Katt/Upload.hs +325/−0
• katt-lib/src/Utils/Katt/Utils.hs +231/−0
• katt-tests/src/TestSourceHandler.hs +56/−0
• katt.cabal +88/−14
• src/Configuration.hs +0/−119
• src/Init.hs +0/−197
• src/Main.hs +0/−78
• src/SourceHandler.hs +0/−114
• src/Upload.hs +0/−314
• src/Utils.hs +0/−229

@@ -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 <problem>\n" <>+  "  Create the corresponding directory and download any available tests.\n\n" <>+  "init-session <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)

@@ -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

@@ -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 "<a href='"+  endLink name = string ">" >> string name >> string "</a>"+  endParser = manyTill anyChar (char '\'') <* endLink "Download"++-- | Try to parse test cases embedded into HTML data.+--   Currently only table-style test cases are supported (e.g. problem 'friends').+parseEmbedded :: GenParser Char st TestParser+parseEmbedded = TestContents <$> 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 "<table class=\"sample\" summary=\"sample data\">"+  endTable  = void $ string "</table>"++  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 "<a href='problems/"+  skip = manyTill anyChar (void (try beginLink) <|> eof)+  tag = do+    problem <- manyTill (letter <|> digit) (char '\'')+    return . ProblemName $ B.pack problem++-- | Given a problem session id, initialize all the corresponding problems.+initializeSession :: Bool -> 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

@@ -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"

@@ -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 "<td class="+    strSep >> string "status" >> strSep >> endTag+    void $ string "<span class=" >> strSep++  -- Skip to the appropiate <td> tag.+  skip = manyTill anyChar (void (try beginStatus) <|> eof)++  -- Parse contents in <td>...</td>.+  -- TODO: check if manyTill can be rewritten to the endTag pattern+  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++-- | Parse the status of all test cases, beginning from any offset in the page data.+--   May return zero test cases when a submission fails+--   with certain status values, e.g. /Compile Error/.+parseTestCases :: GenParser Char st [TestCase] +parseTestCases = skip >> tests+  where+  beginTests = do+    void $ string "<div class="+    strSep >> string "testcases" >> 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 <span [class="status"]>...</span> +  -- where a missing class attribute implies that it hasn't been executed.+  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++-- | 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

@@ -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

@@ -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

@@ -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

@@ -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

@@ -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 "<a href='"-  endLink name = string ">" >> string name >> string "</a>"-  endParser = manyTill anyChar (char '\'') <* endLink "Download"---- | Try to parse test cases embedded into HTML data.---   Currently only table-style test cases are supported (e.g. problem 'friends').-parseEmbedded :: GenParser Char st TestParser-parseEmbedded = TestContents <$> 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 "<table class=\"sample\" summary=\"sample data\">"-  endTable  = void $ string "</table>"--  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 "<a href='problems/"-  skip = manyTill anyChar (void (try beginLink) <|> eof)-  tag = do-    problem <- manyTill (letter <|> digit) (char '\'')-    return . ProblemName $ B.pack problem---- | Given a problem session id, initialize all the corresponding problems.-initializeSession :: Bool -> 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

@@ -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 <problem>\n" <>-  "  Create the corresponding directory and download any available tests.\n\n" <>-  "init-session <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)

@@ -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"

@@ -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 "<td class="-    strSep >> string "status" >> strSep >> endTag-    void $ string "<span class=" >> strSep--  -- Skip to the appropiate <td> tag.-  skip = manyTill anyChar (void (try beginStatus) <|> eof)--  -- Parse contents in <td>...</td>.-  -- TODO: check if manyTill can be rewritten to the endTag pattern-  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---- | Parse the status of all test cases, beginning from any offset in the page data.---   May return zero test cases when a submission fails---   with certain status values, e.g. /Compile Error/.-parseTestCases :: GenParser Char st [TestCase] -parseTestCases = skip >> tests-  where-  beginTests = do-    void $ string "<div class="-    strSep >> string "testcases" >> 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 <span [class="status"]>...</span> -  -- where a missing class attribute implies that it hasn't been executed.-  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---- | 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)

@@ -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