katt (empty) → 0.1.0.0

raw patch · 9 files changed

+1175/−0 lines, 9 filesdep +ConfigFiledep +HsOpenSSLdep +basesetup-changed

Dependencies added: ConfigFile, HsOpenSSL, base, blaze-builder, bytestring, containers, directory, errors, filepath, http-streams, io-streams, mtl, parsec, regex-posix, unix, url, zip-archive

Files

• LICENSE +30/−0
• Setup.hs +2/−0
• katt.cabal +92/−0
• src/Configuration.hs +119/−0
• src/Init.hs +197/−0
• src/Main.hs +78/−0
• src/SourceHandler.hs +114/−0
• src/Upload.hs +314/−0
• src/Utils.hs +229/−0

@@ -0,0 +1,30 @@+Copyright (c) 2013, David Nilsson++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++    * Redistributions of source code must retain the above copyright+      notice, this list of conditions and the following disclaimer.++    * Redistributions in binary form must reproduce the above+      copyright notice, this list of conditions and the following+      disclaimer in the documentation and/or other materials provided+      with the distribution.++    * Neither the name of David Nilsson nor the names of other+      contributors may be used to endorse or promote products derived+      from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain

@@ -0,0 +1,92 @@+name:                katt+version:             0.1.0.0+stability:           experimental++synopsis:            Client for the Kattis judge system.+description:         Unofficial CLI client for the Kattis online judge system (currently in BETA).+                     .+                     Written in a git-like fashion, it supports automatic+                     downloading of test cases, easy submissions, and more.+                     .+                     Basically a problem is initialized as follows+                     (creates a directory and downloads any available test cases):+                     .+                     > > katt init hello+                     > > cd hello+                     .+                     Source files, problem names, and language identification is handled +                     automatically when submitting solutions:+                     .+                     > > vim hello.java+                     > > katt submit+                     > Made submission 4712+                     > Accepted: 1 of 1 test(s) passed+                     .+                     There is also built-in support for problem sessions,+                     which initalizes all problems in the problem list.+                     .+                     Get started by downloading a /.kattisrc/ config from+                     the official site, make sure you have the haskell platform+                     installed, then run /cabal install katt/.+                     .+                     Please note that the beta release is limited to C, C++ and Java.+                     It also only supports running on unix.++homepage:            https://github.com/davnils/katt+bug-reports:         https://github.com/davnils/katt/issues++license:             BSD3+license-file:        LICENSE++author:              David Nilsson+maintainer:          nilsson.dd+code@gmail.com++category:            Utils++build-type:          Simple+cabal-version:       >=1.8+++executable katt+  hs-source-dirs:    src+  main-is:           Main.hs+  other-modules:     Init, Upload, Configuration, Utils, SourceHandler+  ghc-options:       -O2 -threaded -Wall++  -- 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.*++  if impl(ghc <= 7.4.2)+    build-depends:  +                     base == 4.5.*,+                     bytestring >= 0.9.2.1,+                     containers >= 0.4.2.1+  else+    build-depends:  +                     base == 4.6.*,+                     bytestring == 0.10.*,+                     containers == 0.5.*+  +  build-depends:     +                     blaze-builder == 0.3.*,+                     ConfigFile == 1.1.*,+                     directory == 1.2.*,+                     errors == 1.4.*,+                     filepath == 1.3.*,+                     http-streams == 0.6.*,+                     HsOpenSSL >= 0.10.3 && < 0.11,+                     io-streams,+                     mtl == 2.1.*,+                     parsec == 3.1.*,+                     unix == 2.6.*,+                     url == 2.1.*,+                     zip-archive == 0.1.*++source-repository head+  type: git+  location: https://github.com/davnils/katt.git

@@ -0,0 +1,119 @@+{-# 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

@@ -0,0 +1,197 @@+{-# 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

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

@@ -0,0 +1,114 @@+{-# 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"

@@ -0,0 +1,314 @@+{-# 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)

@@ -0,0 +1,229 @@+{-# 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